CDECK  ID>, GENT.   
      SUBROUTINE GENT ( LUN)
C.
C.
C.    ******************************************************************
C.    *                                                                *
C.    *                                                                *
C.    *       PRINT PAM TITLE ON LUN                                   *
C.    *                                                                *
C.    *                                                                *
C.    ******************************************************************
C.
      WRITE (LUN,1000)
      RETURN
 1000 FORMAT('0  GENT  COMPILED FROM PAM FILE= ',
     + 62HGEN      1.42/04   940606 11:30 CERN Program Library GENERAL S    HOLD
     +/)
      END
CDECK  ID>, BINOM.  
      FUNCTION BINOM(X,K)
      DOUBLE PRECISION
     + D,DBINOM

      SROUND(D)=D+(D-SNGL(D))
      BINOM=SROUND(DBINOM(DBLE(X),K))
      RETURN
      END
CDECK  ID>, BINOM64.
      FUNCTION DBINOM(X,K)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C     PARAMETER (IMX = (2**31)-1)
      PARAMETER (IMX = 2147483647)
      CHARACTER NAME*(*)
      CHARACTER*80 ERRTXT

      PARAMETER (NAME = 'KBINOM')

      IF(K .LT. 0) THEN
       H=0
      ELSEIF(K .EQ. 0) THEN
       H=1
      ELSE
       H=X
       A=H
       DO 1 I = 2,K
       A=A-1
    1  H=H*(A/I)
      ENDIF
      DBINOM=H
      RETURN

      ENTRY KBINOM(N,K)

    3 IF(N .GE. 0) THEN
       N1=N
       IS=1
      ELSE
       N1=K-N-1
       IS=(-1)**K
      ENDIF
      IF(K .LT. 0 .OR. K .GT. N1) THEN
       IH=0
      ELSEIF(K .EQ. 0 .OR. K .EQ. N1) THEN
       IH=IS
      ELSE
       IF(K+K .LE. N1) THEN
        K1=K
       ELSE
        K1=N1-K
       ENDIF
       H=N1
       A=H
       DO 2 I = 2,K1
       A=A-1
    2  H=H*(A/I)
       IF(H .LE. IMX) THEN
        IH=IS*NINT(H)
       ELSE
        IH=0
        WRITE(ERRTXT,101) N,K
        CALL MTLPRT(NAME,'B100.1',ERRTXT)
       ENDIF
      ENDIF
      KBINOM=IH
      RETURN
  101 FORMAT('INTEGER RANGE EXCEEDED, N =',I10,',  K = ',I10)
      END

CDECK  ID>, ATG.
      FUNCTION ATG(X1,X2)

      PARAMETER (PI = 3.14159 26535 89793D0)

      ATG=ATAN2(X1,X2)+(PI-SIGN(PI,X1))
      RETURN
      END
CDECK  ID>, ASINH.  
      FUNCTION ASINH(X)
      DOUBLE PRECISION
     + D,DASINH

      SROUND(D)=D+(D-DBLE(SNGL(D)))
      ASINH=SROUND(DASINH(DBLE(X)))
      RETURN
      END
CDECK  ID>, ASINH64.
      FUNCTION DASINH(X)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      CHARACTER*(*) NAME
      PARAMETER(NAME='DASINH')
      DIMENSION C(0:19)

      DATA C( 0) / 0.90649 39198 46333 18D0/
      DATA C( 1) /-0.02704 21478 78869 64D0/
      DATA C( 2) / 0.00211 68145 57973 56D0/
      DATA C( 3) /-0.00021 76650 54603 40D0/
      DATA C( 4) / 0.00002 55196 04364 81D0/
      DATA C( 5) /-0.00000 32329 14485 29D0/
      DATA C( 6) / 0.00000 04310 66959 88D0/
      DATA C( 7) /-0.00000 00596 06134 55D0/
      DATA C( 8) / 0.00000 00084 69211 32D0/
      DATA C( 9) /-0.00000 00012 29008 59D0/
      DATA C(10) / 0.00000 00001 81376 79D0/
      DATA C(11) /-0.00000 00000 27138 46D0/
      DATA C(12) / 0.00000 00000 04107 37D0/
      DATA C(13) /-0.00000 00000 00627 70D0/
      DATA C(14) / 0.00000 00000 00096 72D0/
      DATA C(15) /-0.00000 00000 00015 01D0/
      DATA C(16) / 0.00000 00000 00002 34D0/
      DATA C(17) /-0.00000 00000 00000 37D0/
      DATA C(18) / 0.00000 00000 00000 06D0/
      DATA C(19) /-0.00000 00000 00000 01D0/

      V=ABS(X)
      IF(V .LE. 1) THEN
       H=2*V**2-1
       ALFA=H+H
       B1=0
       B2=0
       DO 1 I = 19,0,-1
       B0=C(I)+ALFA*B1-B2
       B2=B1
    1  B1=B0
       R=SIGN(V*(B0-B2),X)
      ELSE
       R=LOG(X+SQRT(1+X**2))
      ENDIF
      DASINH=R
      RETURN
      END
CDECK  ID>, RSRTNT. 
      SUBROUTINE RSRTNT(K,N,A,B,C,U1,V1,RES,LRL)
      DOUBLE PRECISION
     +  DRS,D
      LOGICAL LRL

      SROUND(D)=D+(D-SNGL(D))
      CALL DSRTNT(K,N,DBLE(A),DBLE(B),DBLE(C),DBLE(U1),DBLE(V1),DRS,LRL)
      RES=SROUND(DRS)
      RETURN
      END
CDECK  ID>, RSRTNT64.   
      SUBROUTINE DSRTNT(K,N,A,B,C,U1,V1,RES,LRL)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL LRL,LLL
      CHARACTER NAME*(*)
      CHARACTER*80 ERRTXT
      PARAMETER (NAME = 'DSRTNT')
      PARAMETER (R1 = 1, HF = R1/2)

      DIMENSION BK(0:4,0:4),SGN(0:4)

      DATA BK(0,0) /1/, (BK(1,J),J=0,1) /1,1/, (BK(2,J),J=0,2) /1,2,1/
      DATA (BK(3,J),J=0,3) /1,3,3,1/, (BK(4,J),J=0,4) /1,4,6,4,1/
      DATA (SGN(J),J=0,4) /1,-1,1,-1,1/

      P(X)=A+B*X+C*X**2
      RT(X)=SQRT(P(X))

      H=0
      LLL=ABS(A)+ABS(B)+ABS(C) .GT. 0
      IF(.NOT.LLL) THEN
       CALL MTLPRT(NAME,'B300.1','A = B = C = 0')
       GO TO 9
      ENDIF
      LLL=ABS(K) .LE. 3 .AND. (N .EQ. 1 .OR. N .EQ. 3)
      IF(.NOT.LLL) THEN
       WRITE(ERRTXT,102) K,N
       CALL MTLPRT(NAME,'B300.2',ERRTXT)
       GO TO 9
      ENDIF

      U=MIN(U1,V1)
      V=MAX(U1,V1)
      LLL=U .EQ. V
      IF(LLL) GO TO 9

      LLL=K .GE. 0 .OR. K .EQ. -1 .AND. U*V .NE. 0
     1             .OR. K .LE. -2 .AND. U*V .GT. 0
      IF(.NOT.LLL) GO TO 9

      DELTA=4*A*C-B**2
      RTD=SQRT(ABS(DELTA))
      IF(C .EQ. 0) THEN
       IF(B .LT. 0) THEN
        X0=-A/B
        LLL=U .LE. X0 .AND. V .LE. X0
       ELSEIF(B .EQ. 0) THEN
        LLL=A .GT. 0
       ELSE
        X0=-A/B
        LLL=U .GE. X0 .AND. V .GE. X0
       ENDIF
      ELSE
       IF(DELTA .GT. 0) THEN
        LLL=C .GT. 0
       ELSEIF(DELTA .EQ. 0) THEN
        IF(C .LT. 0) THEN
         LLL=.FALSE.
        ELSE
         X0=-B/(2*C)
         LLL=U .LT. X0 .AND. V .LT. X0 .OR. U .GT. X0 .AND. V .GT. X0
        ENDIF
       ELSE
        A1=(-B+RTD)/(2*C)
        A2=(-B-RTD)/(2*C)
        W1=MIN(A1,A2)
        W2=MAX(A1,A2)
        IF(C .LT. 0) THEN
         LLL=W1 .LE. U .AND. U .LE. W2 .AND. W1 .LE. V .AND. V .LE. W2
        ELSE
         LLL=U .LE. W1 .AND. V .LE. W1 .OR. U .GE. W2 .AND. V .GE. W2
        ENDIF
       ENDIF
      ENDIF
      IF(.NOT.LLL) GO TO 9

      IF(K .GE. 0) THEN
       IF(C .EQ. 0) THEN
        IF(B .EQ. 0) THEN
         K1=K+1
         H=(V**K1-U**K1)/(K1*SQRT(A)**N)
        ELSE
         N1=2-N
         XV=A+B*V
         XU=A+B*U
         IF(A .EQ. 0) THEN
          K1=2*K+N1
          H=2*(SQRT(XV)**K1-SQRT(XU)**K1)/(K1*B**(K+1))
         ELSE
          HV=SQRT(XV)**N1
          HU=SQRT(XU)**N1
          H1=-XV/A
          H2=-XU/A
          S=N1*(HV-HU)
          DO 1 J = 1,K
    1     S=S+BK(K,J)*(H1**J*HV-H2**J*HU)/(2*J+N1)
          H=2*(-A/B)**K*S/B
         ENDIF
        ENDIF
       ELSE
        IF(N .EQ. 1) THEN
         ASSIGN 11 TO JMP1
         GO TO 10
   11    IF(K .EQ. 0) THEN
          H=H
         ELSEIF(K .EQ. 1) THEN
          H=(RT(V)-RT(U)-HF*B*H)/C
         ELSEIF(K .EQ. 2) THEN
          H1=4*C
          H2=6*B
          H=((H1*V-H2)*RT(V)-(H1*U-H2)*RT(U)+(2*B**2-DELTA)*H)/(8*C**2)
         ELSEIF(K .EQ. 3) THEN
          H1=8*C**2
          H2=10*B*C
          G1=15*B**2
          G2=A*C
          H3=G1-16*G2
          H=(((H1*V-H2)*V+H3)*RT(V)-((H1*U-H2)*U+H3)*RT(U)-
     1       (HF*G1-18*G2)*B*H)/(24*C**3)
         ENDIF
        ELSE
         IF(DELTA .EQ. 0) THEN
          IF(B .EQ. 0) THEN
           IF(K .EQ. 2) THEN
            H=LOG(ABS(V/U))/SQRT(C)**3
           ELSE
            K1=K-2
            H=(V**K1-U**K1)/(K1*SQRT(C)**3)
           ENDIF
           H=SIGN(R1,U)*H
          ELSE
           X0=B/(2*C)
           XV=V+X0
           XU=U+X0
           HV=1/XV**2
           HU=1/XU**2
           H1=-XV/X0
           H2=-XU/X0
           S=HF*(HU-HV)
           DO 2 J = 1,K
           IF(J .NE. 2) THEN
            S=S+BK(K,J)*(H1**J*HV-H2**J*HU)/(J-2)
           ELSE
            S=S+BK(K,2)*LOG(ABS(XV/XU))/X0**2
           ENDIF
    2      CONTINUE
           H=(-X0)**K*S/SQRT(C)**3
           IF(U .LT. -X0) H=-H
          ENDIF
         ELSE
          IF(K .EQ. 0) THEN
           H1=2*C
           H=2*((H1*V+B)/RT(V)-(H1*U+B)/RT(U))/DELTA
          ELSEIF(K .EQ. 1) THEN
           H1=2*A
           H=2*((H1+B*U)/RT(U)-(H1+B*V)/RT(V))/DELTA
           LB1=11
          ELSEIF(K .EQ. 2) THEN
           ASSIGN 12 TO JMP1
           GO TO 10
   12      H1=DELTA-B**2
           H2=2*A*B
           H=(((H1*U-H2)/RT(U)-(H1*V-H2)/RT(V))/DELTA+H)/C
          ELSEIF(K .EQ. 3) THEN
           ASSIGN 13 TO JMP1
           GO TO 10
   13      H1=C*DELTA
           G1=A*C
           G2=3*B**2
           H2=B*(10*G1-G2)
           H3=A*(8*G1-G2)
           H=(2*(((H1*V+H2)*V+H3)/RT(V)-((H1*U+H2)*U+H3)/RT(U))/
     1       DELTA-3*B*H)/(2*C**2)
          ENDIF
         ENDIF
        ENDIF
       ENDIF
      ELSE
       IF(A .EQ. 0) THEN
        IF(B .EQ. 0) THEN
         K1=K-N+1
         H=SIGN(R1,U)*(V**K1-U**K1)/(K1*SQRT(C)**N)
        ELSE
         IF(C .EQ. 0) THEN
          K1=2*K-N+2
          H=2*(SQRT(B*V)**K1-SQRT(B*U)**K1)/(K1*B**(K+1))
         ELSE
          XV=SQRT(C+B/V)
          XU=SQRT(C+B/U)
          N1=N-2
          K1=-K+N1
          S=0
          DO 4 J = 0,K1
          KJ=2*J-N1
    4     S=S+SGN(J)*BK(K1,J)*(XU**KJ-XV**KJ)/(KJ*C**J)
          H=2*(-C/B)**K1*S/B
          IF(U .LT. 0 .AND. V .LT. 0) H=-H
         ENDIF
        ENDIF
       ELSE
        IF(N .EQ. 1) THEN
         ASSIGN 21 TO JMP2
         GO TO 20
   21    IF(K .EQ. -1) THEN
          H=H
         ELSEIF(K .EQ. -2) THEN
          H=(RT(U)/U-RT(V)/V-HF*B*H)/A
         ELSEIF(K .EQ. -3) THEN
          H1=6*B
          H2=4*A
          H=((H1*V-H2)*RT(V)/V**2-(H1*U-H2)*RT(U)/U**2+
     1       (3*B**2-H2*C)*H)/(8*A**2)
         ENDIF
        ELSE
         IF(DELTA .EQ. 0) THEN
          IF(C .EQ. 0) THEN
           IF(K .EQ. -1) THEN
            H=LOG(ABS(V/U))/SQRT(A)**3
           ELSE
            K1=K+1
            H=(V**K1-U**K1)/(K1*SQRT(A)**3)
           ENDIF
          ELSE
           X0=B/(2*C)
           XV=1+X0/V
           XU=1+X0/U
           K1=-K+1
           K2=-K-1
           S=0
           DO 3 J = 0,K1
           KJ=K2-J
           IF(KJ .NE. 0) THEN
            S=S+SGN(J)*BK(K1,J)*(XV**KJ-XU**KJ)/KJ
           ELSE
            S=S+SGN(K2)*BK(K1,K2)*LOG(ABS(XV/XU))
           ENDIF
    3      CONTINUE
           H=-S/(SQRT(C)**3*X0**(K1+1))
           IF(U. LT. -X0) H=-H
          ENDIF
         ELSE
          ASSIGN 22 TO JMP2
          GO TO 20
   22     IF(K .EQ. -1) THEN
           H1=B*C
           H2=B**2-2*A*C
           H=(2*((H1*U+H2)/RT(U)-(H1*V+H2)/RT(V))/DELTA+H)/A
          ELSEIF(K .EQ. -2) THEN
           G1=3*B**2
           G2=A*C
           H1=(G1-8*G2)*C
           H2=(G1-10*G2)*B
           H3=A*DELTA
           H=(((H1*V+H2-H3/V)/RT(V)-(H1*U+H2-H3/U)/RT(U))/DELTA
     1       -3*HF*B*H)/A**2
          ELSEIF(K .EQ. -3) THEN
           G1=A*DELTA
           G2=A*C
           G3=B**2
           G4=15*G3
           H1=2*A*G1
           H2=5*B*G1
           H3=(G4-62*G2)*G3+24*G2**2
           H4=B*C*(G4-52*G2)
           H=((((H2-H1/V)/V-H3-H4*V)/RT(V)-((H2-H1/U)/U-H3-H4*U)/RT(U))
     1        /DELTA+HF*(G4-12*G2)*H)/(4*A**3)
          ENDIF
         ENDIF
        ENDIF
       ENDIF
      ENDIF
      GO TO 9

   10 C2=2*C
      IF(DELTA .GT. 0 .OR. DELTA .LT. 0 .AND. C .GT. 0) THEN
       H=LOG(ABS((2*SQRT(C*P(V))+C2*V+B)/
     1           (2*SQRT(C*P(U))+C2*U+B)))/SQRT(C)
      ELSEIF(DELTA .EQ. 0) THEN
       H=ABS(LOG(ABS((C2*V+B)/(C2*U+B))))/SQRT(C)
      ELSE
       H=(ASIN((C2*U+B)/RTD)-ASIN((C2*V+B)/RTD))/SQRT(-C)
      ENDIF
      GO TO JMP1, (11,12,13)

   20 IF(C .EQ. 0) THEN
       IF(B .EQ. 0) THEN
        H=LOG(ABS(V/U))/SQRT(A)
       ELSE
        IF(A .LT. 0) THEN
         H=2*(ATAN(SQRT(-(A+B*V)/A))-ATAN(SQRT(-(A+B*U)/A)))/SQRT(-A)
        ELSE
         WA=SQRT(A)
         WU=SQRT(A+B*U)
         WV=SQRT(A+B*V)
         H=LOG(ABS((WV-WA)*(WU+WA)/((WV+WA)*(WU-WA))))/WA
        ENDIF
       ENDIF
      ELSE
       A2=2*A
       IF(DELTA .GT. 0 .OR. DELTA .LT. 0 .AND. A .GT. 0) THEN
        H=LOG(ABS((-2*SQRT(A*P(V))+B*V+A2)*U/
     1           ((-2*SQRT(A*P(U))+B*U+A2)*V)))/SQRT(A)
       ELSEIF(DELTA .EQ. 0) THEN
        H=LOG(ABS((B*U+A2)*V/((B*V+A2)*U)))/SQRT(A)
        IF(U*V .GT. 0) H=SIGN(H,U)
       ELSE
        H=(ASIN((B*V+A2)/(V*RTD))-ASIN((B*U+A2)/(U*RTD)))/SQRT(-A)
        IF(U .LT. 0 .AND. V .LT. 0) H=-H
       ENDIF
      ENDIF
      GO TO JMP2, (21,22)

    9 RES=SIGN(R1,V1-U1)*H
      LRL=LLL
      RETURN
  102 FORMAT('ILLEGAL VALUE(S) K = ',I5,', N = ',I5)
      END
CDECK  ID>, ZEROX.  
      SUBROUTINE ZEROX(A0,B0,EPS,MAXF,F,MODE)
C
      CHARACTER NAME*(*)
      PARAMETER (NAME = 'ZEROX')
      CALL MTLPRT(NAME,'C200.0','Not available on this machine')
      RETURN
      END
CDECK  ID>, ZEROX64.
      FUNCTION DZEROX(A0,B0,EPS,MAXF,F,MODE)
C     Based on
C
C        J.C.P. Bus and T.J. Dekker, Two Efficient Algorithms with
C        Guaranteed Convergence for Finding a Zero of a Function,
C        ACM Trans. Math. Software 1 (1975) 330-345.
C
C        (MODE = 1: Algorithm M;    MODE = 2: Algorithm R)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      CHARACTER NAME*(*)
      CHARACTER*80 ERRTXT
      PARAMETER (NAME = 'DZEROX')
      LOGICAL LMT

      DIMENSION IM1(2),IM2(2),LMT(2)

      PARAMETER (Z1 = 1, HALF = Z1/2)

      DATA IM1 /2,3/, IM2 /-1,3/

      IF(MODE .NE. 1 .AND. MODE .NE. 2) THEN
       C=0
       WRITE(ERRTXT,101) MODE
       CALL MTLPRT(NAME,'C200.1',ERRTXT)
       GO TO 99
      ENDIF
      FA=F(B0)
      FB=F(A0)
      IF(FA*FB .GT. 0) THEN
       C=0
       WRITE(ERRTXT,102) A0,B0
       CALL MTLPRT(NAME,'C200.2',ERRTXT)
       GO TO 99
      ENDIF
      ATL=ABS(EPS)
      B=A0
      A=B0
      LMT(2)=.TRUE.
      MF=2
    1 C=A
      FC=FA
    2 IE=0
    3 IF(ABS(FC) .LT. ABS(FB)) THEN
       IF(C .NE. A) THEN
        D=A
        FD=FA
       END IF
       A=B
       B=C
       C=A
       FA=FB
       FB=FC
       FC=FA
      END IF
      TOL=ATL*(1+ABS(C))
      H=HALF*(C+B)
      HB=H-B
      IF(ABS(HB) .GT. TOL) THEN
       IF(IE .GT. IM1(MODE)) THEN
        W=HB
       ELSE
        TOL=TOL*SIGN(Z1,HB)
        P=(B-A)*FB
        LMT(1)=IE .LE. 1
        IF(LMT(MODE)) THEN
         Q=FA-FB
         LMT(2)=.FALSE.
        ELSE
         FDB=(FD-FB)/(D-B)
         FDA=(FD-FA)/(D-A)
         P=FDA*P
         Q=FDB*FA-FDA*FB
        END IF
        IF(P .LT. 0) THEN
         P=-P
         Q=-Q
        END IF
        IF(IE .EQ. IM2(MODE)) P=P+P
        IF(P .EQ. 0 .OR. P .LE. Q*TOL) THEN
         W=TOL
        ELSEIF(P .LT. HB*Q) THEN
         W=P/Q
        ELSE
         W=HB
        END IF
       END IF
       D=A
       A=B
       FD=FA
       FA=FB
       B=B+W
       MF=MF+1
       IF(MF .GT. MAXF) THEN
        CALL MTLPRT(NAME,'C200.3','TOO MANY FUNCTION CALLS')
        GO TO 99
       ENDIF
       FB=F(B)
       IF(FB .EQ. 0 .OR. SIGN(Z1,FC) .EQ. SIGN(Z1,FB)) GO TO 1
       IF(W .EQ. HB) GO TO 2
       IE=IE+1
       GO TO 3
      END IF
      DZEROX=C
   99 CONTINUE
      RETURN
  101 FORMAT('MODE = ',I3,' ILLEGAL')
  102 FORMAT('F(A) AND F(B) HAVE THE SAME SIGN, A = ',1P,D15.8,
     1       ', B = ',D15.8)
      END
CDECK  ID>, SNLEQ.  
      SUBROUTINE SNLEQ(N,X,F,FTOL,XTOL,MAXF,IPRT,INFO,SUB,W)
C
      CHARACTER NAME*(*)
      PARAMETER (NAME = 'SNLEQ')
      CALL MTLPRT(NAME,'C201.0','Not available on this machine')
      RETURN
      END
CDECK  ID>, SNLEQ64.
      SUBROUTINE DSNLEQ(N,X,F,FTOL,XTOL,MAXF,IPRT,INFO,SUB,W)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

C     Based on   J.J. More  and  M.Y. Cosnard
C
C       ALGORITHM 554 BRENTM, A Fortran Subroutine for the
C       Numerical Solution of Systems of Nonlinear Equations [C5]
C
C     ACM Trans. Math. Software 6 (1980) 240-251.

      DIMENSION X(N),F(N),W(N,*),MPT(288)
      LOGICAL LCV

      PARAMETER (Z1 = 1, SCALE = 10, P05 = 5*Z1/100)
C**** EPS = SQRT(SMALLEST FP.NUMBER)
C     EPS = 1 / SQRT( 16D0**13 )
      PARAMETER (EPS =  0.37252 90298 46191 40625D-08)
      DATA (MPT(I),I=1,288)
     1/1* 1,1* 2,3* 3,3* 4,4* 5,4* 6,4* 7,4* 8,5* 9,5*10,5*11,5*12,
     2 5*13,5*14,6*15,6*16,5*17,6*18,6*19,6*20,7*21,6*22,6*23,7*24,
     3 6*25,7*26,6*27,7*28,7*29,7*30,7*31,7*32,7*33,7*34,7*35,7*36,
     4 8*37,7*38,7*39,8*40,7*41,8*42,7*43,8*44,8*45,7*46,8*47,8*48/

      INFO=0
      IF(N .LE. 0 .OR. FTOL .LE. 0 .OR. XTOL .LE. 0) RETURN
C
C     Find optimal MOPT for iterative refinement
C
      IF(N .LE. 288) THEN
       MOPT=MPT(N)
      ELSE
       H=0
       DO 1 I = 49,N
       TEMP=LOG(I+Z1)/(N+2*I+1)
       IF(TEMP .LT. H) THEN
        MOPT=I-1
        GO TO 2
       ENDIF
    1  H=TEMP
      ENDIF

    2 IFLAG=0
      NUMF=0
      NFCALL=0

      NIER6=-1
      NIER7=-1
      NIER8=0
      FNORM=0
      DIFIT=0
      XNORM=0
      DO 10 I = 1,N
   10 XNORM=MAX(XNORM,ABS(X(I)))
      DELTA=SCALE*XNORM
      IF(XNORM .EQ. 0) DELTA=SCALE

   20 IF(IPRT .NE. 0) WRITE(6,'(1X,I5,D25.14)') (I,X(I),I=1,N)

      NSING=N
      FNORM1=FNORM
      DIFIT1=DIFIT
      FNORM=0
C
C     Compute step H for the divided difference which approximates
C     the K-th row of the Jacobian matrix
C
      H=EPS*XNORM
      IF(H .EQ. 0) H=EPS
      DO 40 J = 1,N
      DO 30 I = 1,N
   30 W(I,J+3)=0
      W(J,J+3)=H
   40 W(J,2)=X(J)
C
C     Enter a subiteration
C
      DO 150 K = 1,N
      IFLAG=K
      CALL SUB(N,W(1,2),F,IFLAG)
      FKY=F(K)
      NFCALL=NFCALL+1
      NUMF=NFCALL/N
      IF(IFLAG .LT. 0) GO TO 230
      FNORM=MAX(FNORM,ABS(FKY))
C
C     Compute the K-th row of the Jacobian matrix
C
      DO 60 J = K,N
      DO 50 I = 1,N
   50 W(I,3)=W(I,2)+W(I,J+3)
      CALL SUB(N,W(1,3),F,IFLAG)
      FKZ=F(K)
      NFCALL=NFCALL+1
      NUMF=NFCALL/N
      IF(IFLAG .LT. 0) GO TO 230
   60 W(J,1)=FKZ-FKY
      F(K)=FKY
C
C     Compute the Householder transformation to reduce the K-th row
C     of the Jacobian matrix to a multiple of the K-th unit vector
C
      ETA=0
      DO 70 I = K,N
   70 ETA=MAX(ETA,ABS(W(I,1)))
      IF(ETA .EQ. 0) GO TO 150
      NSING=NSING-1
      SKNORM=0
      DO 80 I = K,N
      W(I,1)=W(I,1)/ETA
   80 SKNORM=SKNORM+W(I,1)**2
      SKNORM=SQRT(SKNORM)
      IF(W(K,1) .LT. 0) SKNORM=-SKNORM
      W(K,1)=W(K,1)+SKNORM
C
C     Apply the transformation
C
      DO 90 I = 1,N
   90 W(I,3)=0
      DO 100 J = K,N
      DO 100 I = 1,N
  100 W(I,3)=W(I,3)+W(J,1)*W(I,J+3)
      DO 120 J = K,N
      TEMP=W(J,1)/(SKNORM*W(K,1))
      DO 120 I = 1,N
  120 W(I,J+3)=W(I,J+3)-TEMP*W(I,3)
C
C     Compute the subiterate
C
      W(K,1)=SKNORM*ETA
      TEMP=FKY/W(K,1)
      IF(H*ABS(TEMP) .GT. DELTA) TEMP=SIGN(DELTA/H,TEMP)
      DO 140 I = 1,N
  140 W(I,2)=W(I,2)+TEMP*W(I,K+3)
  150 CONTINUE
C
C     Compute the norms of the iterate and correction vector
C
      XNORM=0
      DIFIT=0
      DO 160 I = 1,N
      XNORM=MAX(XNORM,ABS(W(I,2)))
      DIFIT=MAX(DIFIT,ABS(X(I)-W(I,2)))
  160 X(I)=W(I,2)
C
C     Update the bound on the correction vector
C
      DELTA=MAX(DELTA,SCALE*XNORM)
C
C     Determine the progress of the iteration
C
      LCV=FNORM .LT. FNORM1 .AND. DIFIT .LT. DIFIT1 .AND. NSING .EQ. 0
      NIER6=NIER6+1
      NIER7=NIER7+1
      NIER8=NIER8+1
      IF(LCV) NIER6=0
      IF(FNORM .LT. FNORM1 .OR. DIFIT .LT. DIFIT1) NIER7=0
      IF(DIFIT .GT. EPS*XNORM) NIER8=0
C
C     Tests for convergence
C
      IF(FNORM .LE. FTOL) INFO=1
      IF(DIFIT .LE. XTOL*XNORM .AND. LCV) INFO=2
      IF(FNORM .LE. FTOL .AND. INFO .EQ. 2) INFO=3
      IF(INFO .NE. 0) GO TO 230
C
C     Tests for termination
C
      IF(NUMF .GE. MAXF) INFO=4
      IF(NSING .EQ. N) INFO=5
      IF(NIER6 .EQ. 5) INFO=6
      IF(NIER7 .EQ. 3) INFO=7
      IF(NIER8 .EQ. 4) INFO=8
      IF(INFO .NE. 0) GO TO 230
      IF(.NOT.LCV .OR. DIFIT .GT. P05*XNORM) GO TO 20
C
C     Iterative refinement  (if the iteration is converging)
C
      DO 210 M = 2,MOPT
      FNORM1=FNORM
      FNORM=0
      DO 190 K = 1,N
      IFLAG=K
      CALL SUB(N,W(1,2),F,IFLAG)
      FKY=F(K)
      NFCALL=NFCALL+1
      NUMF=NFCALL/N
      IF(IFLAG .LT. 0) GO TO 230
      FNORM=MAX(FNORM,ABS(FKY))
C
C     Iterative refinement is terminated if it does not give a
C     reduction on residuals
C
      IF(FNORM .GE. FNORM1) THEN
       FNORM=FNORM1
       GO TO 20
      ENDIF
      TEMP=FKY/W(K,1)
      DO 180 I = 1,N
  180 W(I,2)=W(I,2)+TEMP*W(I,K+3)
  190 CONTINUE
C
C     Compute the norms of the iterate and correction vector
C
      XNORM=0
      DIFIT=0
      DO 200 I = 1,N
      XNORM=MAX(XNORM,ABS(W(I,2)))
      DIFIT=MAX(DIFIT,ABS(X(I)-W(I,2)))
  200 X(I)=W(I,2)
C
C     Stopping criteria for iterative refinement
C
      IF(FNORM .LE. FTOL) INFO=1
      IF(DIFIT .LE. XTOL*XNORM) INFO=2
      IF(FNORM .LE. FTOL .AND. INFO .EQ. 2) INFO=3
      IF(NUMF .GE. MAXF .AND. INFO .EQ. 0) INFO=4
      IF(INFO .NE. 0) GO TO 230
  210 CONTINUE
      GO TO 20

  230 IF(IFLAG .LT. 0) INFO=IFLAG
      RETURN
      END
CDECK  ID>, RMULLZ. 
      SUBROUTINE RMULLZ(A,N,MAXITR,Z0)
C
      CHARACTER*(*) NAME
      PARAMETER( NAME='RMULLZ')
      CALL MTLPRT(NAME,'C202.0','Not available on this machine')
      RETURN
      END
CDECK  ID>, RMULLZ64.   
      SUBROUTINE DMULLZ(A,N,MAXITR,Z0)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMPLEX*16
     +  Z0,Z,DX,X,X3,Y1,Y2,Y,TE(7)
      LOGICAL LSW
      DIMENSION A(0:*),Z0(*)
      CHARACTER*(*) NAME
      PARAMETER( NAME='DMULLZ')
      PARAMETER (Z1 = 1, HF = Z1/2)
      PARAMETER (ETA1 = 1D-14, ETA2 = 6D-8, BIG = 1D20)
      PARAMETER (C1 = 0.9D0, C2 = 0.002D0, C3 = 0.1D0)

      DOUBLE PRECISION
     +      GREAL,GIMAG,XARG,YARG
      COMPLEX*16
     +      ZARG,GCONJG,GCMPLX
      GREAL( ZARG)=DREAL( ZARG)
      GIMAG( ZARG)=DIMAG( ZARG)
      GCONJG(ZARG)=DCONJG(ZARG)
      GCMPLX(XARG,YARG)=DCMPLX(XARG,YARG)
      SUMABS(Z)=ABS(GREAL(Z))+ABS(GIMAG(Z))

      IF(N .LE. 0) RETURN
      IF(A(0) .EQ. 0) THEN
       CALL MTLPRT(NAME,'C202.1','A(0) = 0')
       RETURN
      ENDIF

      N1=N
    2 IF(N1 .EQ. 1) THEN
       Z0(1)=-A(1)/A(0)
       RETURN
      ENDIF
      IF(A(N1) .EQ. 0) THEN
       Z0(N1)=0
       N1=N1-1
       GO TO 2
      ENDIF

      SCALE=ABS(A(N1)/A(0))**(Z1/N1)
      B=A(0)
      DO 6 I = 1,N1
      B=B*SCALE
    6 Z0(I)=A(I)/B
      IF(N1 .EQ. 2) GO TO 1

   10 LSW=.TRUE.
      Y1=Z0(1)+1
      Y2=Z0(1)-1
      DO 11 I = 2,N1
      Y1=Z0(I)+Y1
   11 Y2=Z0(I)-Y2
      Y=Z0(N1)
      X=0
      DX=1

      TE(1)=-2
   12 TE(2)=Y2/Y
      TE(3)=(Y1-Y2)/(Y*TE(1))
      DO 17 ITER = 1,MAXITR
      TE(4)=TE(2)-1
      TE(5)=(TE(4)-TE(3))/(TE(1)+1)
      TE(6)=HF*(TE(5)+TE(4))
      TE(7)=SQRT(TE(6)**2+TE(5))
      TE(1)=TE(6)+TE(7)
      TE(7)=TE(6)-TE(7)
      IF(ABS(TE(1)) .LE. ABS(TE(7))) THEN
       IF(TE(7) .EQ. 0) TE(7)=C1
       TE(1)=TE(7)
      ENDIF
      DX=DX/TE(1)
      X=DX+X
      EPSI=SUMABS(X)*ETA1
      IF(SUMABS(DX) .LT. EPSI .AND. SUMABS(Y) .LT. C2) GO TO 18
      Y2=Y
      Y=X+Z0(1)
      DO 21 I = 2,N1
   21 Y=Y*X+Z0(I)
      IF(Y .EQ. 0) GO TO 18

   15 IF(SUMABS(Y) .GE. 100*SUMABS(Y2) .AND. SUMABS(DX) .GE. EPSI) THEN
       TE(1)=2*TE(1)
       DX=HF*DX
       X=X-DX
       Y=X+Z0(1)
       DO 22 I = 2,N1
   22  Y=Y*X+Z0(I)
       IF(Y .EQ. 0) GO TO 18
       GOTO 15
      ENDIF

      TE(2)=Y2/Y
      TE(3)=(TE(2)/TE(1))*TE(4)
   17 CONTINUE

      CN=ABS(Z0(N1))
      IF(ABS(CN-1) .LT. C3) THEN
       DO 40 I = 1,N1
   40  Z0(I)=BIG
       CALL MTLPRT(NAME,'C202.2','TOO MANY ITERATIONS')
       RETURN
      ENDIF
      S=CN**(-Z1/N1)
      SCALE=SCALE/S
      B=1
      DO 30 I = 1,N1
      B=B*S
   30 Z0(I)=Z0(I)*B
      GO TO 10

   20 IF(ABS(GIMAG(X)) .LT. ABS(GREAL(X))*ETA2) GO TO 10
      LSW=.FALSE.
      X3=GCONJG(X)
      DX=GCONJG(DX)
      TE(1)=GCONJG(TE(1))
      X=X3-DX
      Y=X+Z0(1)
      DO 51 I = 2,N1
   51 Y=Y*X+Z0(I)
      IF(Y .EQ. 0) GO TO 18
      Y2=Y
      X=X-DX*TE(1)
      Y=X+Z0(1)
      DO 52 I = 2,N1
   52 Y=Y*X+Z0(I)
      IF(Y .EQ. 0) GO TO 18
      Y1=Y
      X=X3
      Y=X+Z0(1)
      DO 53 I = 2,N1
   53 Y=Y*X+Z0(I)
      IF(Y .NE. 0) GO TO 12

   18 Z0(N1)=X*SCALE
      N1=N1-1
      Z0(1)=X+Z0(1)
      DO 19 I = 2,N1
   19 Z0(I)=Z0(I-1)*X+Z0(I)
      IF(N1 .GT. 2) THEN
       IF(LSW) GO TO 20
       GO TO 10
      ENDIF

    1 Z0(2)=(SQRT((HF*Z0(1))**2-Z0(2))-HF*Z0(1))*SCALE
      Z0(1)=-Z0(1)*SCALE-Z0(2)
      RETURN
      END
CDECK  ID>, RTEQ3.  
      SUBROUTINE RTEQ3(R,S,T,X,D)
C
      CHARACTER NAME*(*)
      PARAMETER (NAME = 'RTEQ3')
      CALL MTLPRT(NAME,'C207.0','Not available on this machine')
      RETURN
      END
CDECK  ID>, RTEQ364.
      SUBROUTINE DRTEQ3(R,S,T,X,D)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMPLEX*16
     +  I,Z(0:2)
      DOUBLE PRECISION
     + ZQ1,QQ,PP,Q1,Q2,Q3
      DIMENSION X(*),Y(0:2)

      PARAMETER(EPS = 1D-6, DELTA = 1D-15)
      PARAMETER(I = (0,1), ZD1 = 1, ZQ1 = 1)
      PARAMETER(R1 = 2*ZD1/27, R2 = ZD1/2, R3 = ZD1/3)
      PARAMETER(W3 = 1.73205 08075 68877 294D0, R4 = W3/2)
      PARAMETER(Q1 = 2*ZQ1/27, Q2 = ZQ1/2, Q3 = ZQ1/3)

      IF(S .EQ. 0 .AND. T .EQ. 0) THEN
       X(1)=-R
       X(2)=0
       X(3)=0
       D=0
       RETURN
      ENDIF
      P=S-R3*R**2
      Q=(R1*R**2-R3*S)*R+T
      D=(R2*Q)**2+(R3*P)**3
      IF(ABS(D) .LE. EPS) THEN
       PP=S-Q3*R**2
       QQ=(Q1*R**2-Q3*S)*R+T
       D=(Q2*QQ)**2+(Q3*PP)**3
       P=PP
       Q=QQ
      ENDIF
      H=R3*R
      H1=R2*Q
      IF(D .GT. DELTA) THEN
       H2=SQRT(D)
       U0=-H1+H2
       V0=-H1-H2
       U=SIGN(ABS(U0)**R3,U0)
       V=SIGN(ABS(V0)**R3,V0)
       X(1)=U+V-H
       X(2)=-R2*(U+V)-H
       X(3)=R4*ABS(U-V)
       IF(ABS(U0) .LE. EPS .OR. ABS(V0) .LE. EPS) THEN
        Y(0)=X(1)
        DO 1 K = 0,1
    1   Y(K+1)=Y(K)-(((Y(K)+R)*Y(K)+S)*Y(K)+T)/((3*Y(K)+2*R)*Y(K)+S)
        X(1)=Y(2)
        Z(0)=X(2)+I*X(3)
        DO 2 K = 0,1
    2   Z(K+1)=Z(K)-(((Z(K)+R)*Z(K)+S)*Z(K)+T)/((3*Z(K)+2*R)*Z(K)+S)
        X(2)=Z(2)
        X(3)=-I*Z(2)
       ENDIF
      ELSEIF(ABS(D) .LE. DELTA) THEN
       D=0
       U=SIGN(ABS(H1)**R3,-H1)
       X(1)=U+U-H
       X(2)=-U-H
       X(3)=X(2)
       IF(ABS(H1) .LE. EPS) THEN
        Y(0)=X(1)
        DO 5 K = 0,1
        H1=(3*Y(K)+2*R)*Y(K)+S
        IF(ABS(H1) .GT. DELTA) THEN
         Y(K+1)=Y(K)-(((Y(K)+R)*Y(K)+S)*Y(K)+T)/H1
        ELSE
         X(1)=-R3*R
         X(2)=X(1)
         X(3)=X(1)
         RETURN
        ENDIF
    5   CONTINUE
        X(1)=Y(2)
        X(2)=-R2*(R+X(1))
        X(3)=X(2)
       ENDIF
      ELSE
       H3=SQRT(ABS(R3*P)**3)
       H2=R3*ACOS(-H1/H3)
       H1=H3**R3
       U=H1*COS(H2)
       V=W3*H1*SIN(H2)
       X(1)=U+U-H
       X(2)=-U-V-H
       X(3)=-U+V-H
       IF(H3 .LE. EPS .OR. X(1) .LE. EPS .OR. X(2) .LE .EPS .OR.
     1                     X(3) .LE. EPS) THEN
        DO 3 J = 1,3
        Y(0)=X(J)
        DO 4 K = 0,1
    4   Y(K+1)=Y(K)-(((Y(K)+R)*Y(K)+S)*Y(K)+T)/((3*Y(K)+2*R)*Y(K)+S)
    3   X(J)=Y(2)
       ENDIF
      ENDIF
      RETURN
      END
CDECK  ID>, RTEQ4.  
      SUBROUTINE RTEQ4(A,B,C,D,Z,DC,MT)
C
      CHARACTER NAME*(*)
      PARAMETER (NAME = 'RTEQ4')
      CALL MTLPRT(NAME,'C208.0','Not available on this machine')
      RETURN
      END
CDECK  ID>, RTEQ464.
      SUBROUTINE DRTEQ4(A,B,C,D,Z,DC,MT)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMPLEX*16
     +  I,Z,Z0,W1,W2,W3
      DOUBLE PRECISION
     +      ZQ1,AA,PP,QQ,RR,Q1,Q2,Q3,Q4,Q8
      DIMENSION Z(*),Z0(4),U(3),V(3)

      PARAMETER(I = (0,1), ZD1 = 1, ZQ1 = 1)
      PARAMETER(R4 = ZD1/4, R12 = ZD1/12)
      PARAMETER(Q2 = ZQ1/2, Q4 = ZQ1/4, Q8 = ZQ1/8)
      PARAMETER(Q1 = 3*ZQ1/8, Q3 = 3*ZQ1/16)

      IF(B .EQ. 0 .AND. C .EQ. 0) THEN
       IF(D .EQ. 0) THEN
        MT=1
        Z(1)=-A
        Z(2)=0
        Z(3)=0
        Z(4)=0
        DC=0
        RETURN
       ELSEIF(A .EQ. 0) THEN
        IF(D .GT. 0) THEN
         MT=2
         Z(1)=SQRT(I*SQRT(D))
         Z(2)=-Z(1)
         Z(4)=SQRT(-Z(1)**2)
         Z(3)=-Z(4)
        ELSE
         MT=3
         Z(1)=SQRT(SQRT(-D))
         Z(2)=-Z(1)
         Z(3)=SQRT(-Z(1)**2)
         Z(4)=-Z(3)
        ENDIF
        DC=(-R12*D)**3
        RETURN
       ENDIF
      ENDIF
      AA=A**2
      PP=B-Q1*AA
      QQ=C-Q2*A*(B-Q4*AA)
      RR=D-Q4*(A*C-Q4*AA*(B-Q3*AA))
      RC=Q2*PP
      SC=Q4*(Q4*PP**2-RR)
      TC=-(Q8*QQ)**2
      CALL DRTEQ3(RC,SC,TC,U,DC)
      Q=QQ
      H=R4*A
      IF(DC .EQ. 0) U(3)=U(2)
      IF(DC .LE. 0) THEN
       MT=2
       V(1)=ABS(U(1))
       V(2)=ABS(U(2))
       V(3)=ABS(U(3))
       V1=MAX(V(1),V(2),V(3))
       IF(V1 .EQ. V(1)) THEN
        K1=1
        V2=MAX(V(2),V(3))
       ELSEIF(V1 .EQ. V(2)) THEN
        K1=2
        V2=MAX(V(1),V(3))
       ELSE
        K1=3
        V2=MAX(V(1),V(2))
       ENDIF
       IF(V2 .EQ. V(1)) THEN
        K2=1
       ELSEIF(V2 .EQ. V(2)) THEN
        K2=2
       ELSE
        K2=3
       ENDIF
       W1=SQRT(U(K1)+I*0)
       W2=SQRT(U(K2)+I*0)
      ELSE
       MT=3
       W1=SQRT(U(2)+I*U(3))
       W2=SQRT(U(2)-I*U(3))
      ENDIF
      W3=0
      IF(W1*W2 .NE. 0) W3=-Q/(8*W1*W2)
      Z0(1)=W1+W2+W3-H
      Z0(2)=-W1-W2+W3-H
      Z0(3)=-W1+W2-W3-H
      Z0(4)=W1-W2-W3-H
      IF(MT .EQ. 2) THEN
       IF(U(K1) .GE. 0 .AND. U(K2) .GE. 0) THEN
        MT=1
        DO 1 J = 1,4
        RZ0=Z0(J)
    1   Z(J)=RZ0
       ELSEIF(U(K1) .GE. 0 .AND. U(K2) .LT. 0) THEN
        Z(1)=Z0(1)
        Z(2)=Z0(4)
        Z(3)=Z0(3)
        Z(4)=Z0(2)
       ELSEIF(U(K1) .LT. 0 .AND. U(K2) .GE. 0) THEN
        Z(1)=Z0(1)
        Z(2)=Z0(3)
        Z(3)=Z0(4)
        Z(4)=Z0(2)
       ELSEIF(U(K1) .LT. 0 .AND. U(K2) .LT. 0) THEN
        Z(1)=Z0(1)
        Z(2)=Z0(2)
        Z(3)=Z0(4)
        Z(4)=Z0(3)
       ENDIF
      ELSEIF(MT .EQ. 3) THEN
       DO 2 J = 1,2
       RZ0=Z0(J)
    2  Z(J)=RZ0
       Z(3)=Z0(4)
       Z(4)=Z0(3)
      ENDIF
      RETURN
      END
CDECK  ID>, CPOLYZ64.   
      SUBROUTINE WPOLYZ(C,N,MAXIT,Z0,H)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      CHARACTER NAME*(*)
      PARAMETER (NAME = 'WPOLYZ')
C
C     Based on
C      T. Pomentale, Homotopy methods for polynomial equations,
C      J. Inst. Maths Applics 13 (1974) 201-213

C     Revised version of a routine originally written by T. Pomentale

      COMPLEX*16
     + C(0:*),Z0(*),F(100),B(100),Z,CN,CD,FZ,FF,F1,F2,V,ZZ,Z1,ZV,IU
      LOGICAL LMD
      DIMENSION H(*)
      CHARACTER*80 ERRTXT

      PARAMETER (EPS = 1D-14)
      PARAMETER (IU = (0D0,1D0))
      PARAMETER (R0 = 0, R1 = 1, BIG1 = 1D7, BIG2 = BIG1/10, HF = R1/2)
      PARAMETER (FAC1 = 9*R1/10, FAC2 = 2+100*FAC1*EPS)
      PARAMETER (PI = 3.14159 26535 89793 24D0, PI2 = 2*PI)

      TST(Z1,ZV)=DREAL(Z1)*DREAL(ZV)+DIMAG(Z1)*DIMAG(ZV)

      IF(N .LE. 0) RETURN
      IF(C(0) .EQ. 0) THEN
       CALL MTLPRT(NAME,'C209.1','A(0) = 0')
       RETURN
      ENDIF
      IF(N .EQ. 1) THEN
       Z0(1)=-C(1)/C(0)
       H(1)=0
       RETURN
      ENDIF
      IF(N .EQ. 2) THEN
       H(1)=0
       H(2)=0
       Z0(2)=(-C(1)+SQRT(C(1)**2-4*C(0)*C(2)))/(2*C(0))
       Z0(1)=-Z0(2)-C(1)/C(0)
       RETURN
      ENDIF
      LMD=.FALSE.
      DO 1 K = 1,N
    1 LMD=LMD .OR. Z0(K) .NE. 0
      M=0
      WN=SQRT(N+R0)
      Z=1+IU
      N1=N

      DO 3 K = 1,N+1
      H(K)=1
    3 B(K)=C(K-1)
    6 DO 10 K = 1,N-2
      IF(B(N1+1) .EQ. 0) GO TO 18
      IF(LMD) Z=Z0(K)
      IF(M .GE. MAXIT) THEN
       CALL MTLPRT(NAME,'C209.2','TOO MANY ITERATIONS')
       RETURN
      ENDIF

      S=BIG1
      DO 61 I = 1,N1+1
   61 F(I)=B(I)
      ZA=ABS(Z)
      HH=HF*ABS(B(1))
      DO 62 I = 2,N1+1
      F(I)=Z*F(I-1)+F(I)
      D=ABS(F(I))
   62 HH=ZA*HH+D
      DO 63 L = 1,2
      DO 63 I = 2,N1-L+1
   63 F(I)=Z*F(I-1)+F(I)
      M=M+1
      IF(D .LE. EPS*(FAC2*HH-D)) GO TO 13

    7 D1=S
    8 NI=0
      V=Z
      FZ=F(N1+1)
      FF=FZ
      F1=F(N1)
      F2=F(N1-1)

    9 NI=NI+1
      IH=0
      Z=V
      F(N1+1)=FF
      F(N1)=F1
      F(N1-1)=F2
   11 IH=IH+1
      IF(IH .GT. NI) GO TO 9
      CN=F(N1+1)-(NI-IH)*FZ/(NI+R0)
      CD=F(N1)**2-2*F(N1-1)*CN
      CN=CN*F(N1)
      IF(ABS(CN) .GT. 10*ABS(CD)) GO TO 9
      Z=Z-CN/CD
      IF(M .GE. MAXIT) THEN
       CALL MTLPRT(NAME,'C209.2','TOO MANY ITERATIONS')
       RETURN
      ENDIF

      DO 71 I = 1,N1+1
   71 F(I)=B(I)
      ZA=ABS(Z)
      HH=HF*ABS(B(1))
      DO 72 I = 2,N1+1
      F(I)=Z*F(I-1)+F(I)
      D=ABS(F(I))
   72 HH=ZA*HH+D
      DO 73 L = 1,2
      DO 73 I = 2,N1-L+1
   73 F(I)=Z*F(I-1)+F(I)
      M=M+1
      ERR=EPS*(FAC2*HH-D)
      IF(D .LE. ERR) GO TO 13
      S=ABS(F(N1+1))
      IF(S .LE. FAC1*D1) GO TO 7
      IF(S .LT. BIG2*ERR) GO TO 13
      S1=ABS(F(N1))
      S2=ABS(F(N1-1))
      S3=1+ABS(Z)
      IF(2*S1 .GT. S2*S3 .OR. 10*S .LT. S1*S3) GO TO 11

      ZZ=Z
      KK=2
      M1=1
      S=S1/S2
   40 DT=PI2/KK
      DO 42 J=1,KK,M1
      ZV=S*EXP(IU*(J*DT))
      Z=ZZ+ZV
      IF(M .GE. MAXIT) GO TO 44
      DO 41 I = 1,N1+1
   41 F(I)=B(I)
      DO 43 L = 0,1
      DO 43 I = 2,N1-L+1
   43 F(I)=Z*F(I-1)+F(I)
      M=M+1
      IF(F(N1) .NE. 0) THEN
       Z1=(ABS(F(N1))*F(N1+1))/F(N1)
       IF(TST(Z1,ZV) .LT. 0) GO TO 44
      ENDIF
   42 CONTINUE
      M1=2
      KK=2*KK
      IF(KK .LE. 8) GO TO 40

   44 S2=1
      S=ABS(F(N1+1))
      S1=ABS(F(N1))
      IF(S .GT. S1*(1+ABS(Z))) S2=S1/(2*S)
      Z=Z-S2*F(N1+1)/F(N1)
      IF(M .GE. MAXIT) THEN
       CALL MTLPRT(NAME,'C209.2','TOO MANY ITERATIONS')
       RETURN
      ENDIF
      DO 81 I = 1,N1+1
   81 F(I)=B(I)
      DO 83 L = 0,2
      DO 83 I = 2,N1-L+1
   83 F(I)=Z*F(I-1)+F(I)
      M=M+1
      GO TO 8

   18 Z=0
      H(K)=0

   13 IF(Z .EQ. 0) GO TO 53
      X=ABS(B(N1+1))
      Z1=1
      JR=0
      DO 51 J = 2,N1
      Z1=Z*Z1
      Y=ABS(Z1*B(N1-J+2))
      IF(Y .GT. X) THEN
       X=Y
       JR=J-1
      ENDIF
   51 CONTINUE
      IF(JR .GT. 0) THEN
       B(N1+1)=-B(N1+1)/Z
       DO 52 J = N1,N1-JR+2,-1
   52  B(J)=(B(J+1)-B(J))/Z
       DO 55 J = N1-JR+1,N1
   55  B(J)=B(J+1)
      ENDIF
      DO 54 J = 2,N1-JR
   54 B(J)=B(J)+Z*B(J-1)

   53 N1=N1-1
      Z0(K)=Z
   10 CONTINUE
      Z0(N)=(-B(2)+SQRT(B(2)**2-4*B(1)*B(3)))/(2*B(1))
      Z0(N-1)=-Z0(N)-B(2)/B(1)
      IF(B(3) .EQ. 0) H(N)=0
      IF(B(2) .EQ. 0 .AND. B(3) .EQ. 0) H(N-1)=0
   12 CONTINUE

      DO 14 K=1,N
      IF(H(K) .EQ. 0) GO TO 14
      H(K)=0

      DO 91 I = 1,N+1
   91 F(I)=C(I-1)
      ZA=ABS(Z0(K))
      HH=HF*ABS(C(0))
      DO 92 I = 2,N+1
      F(I)=Z0(K)*F(I-1)+F(I)
      D=ABS(F(I))
   92 HH=ZA*HH+D
      DO 93 L = 1,2
      DO 93 I = 2,N-L+1
   93 F(I)=Z0(K)*F(I-1)+F(I)
      IF(F(N+1) .EQ. 0 .AND. F(N) .EQ. 0) GO TO 14
      ERR=EPS*(FAC2*HH-D)
      IF(D .LE. ERR) THEN
       S=WN*ERR
      ELSE
       S=WN*ABS(F(N+1))
      ENDIF
      S1=SQRT(ABS(F(N)**2-2*F(N-1)*F(N+1)))
      IF(S .LE. 10*S1*ABS(Z0(K))) THEN
       H(K)=S/S1
      ELSE
       WRITE(ERRTXT,103) M
       CALL MTLPRT(NAME,'C209.3',ERRTXT)
      ENDIF
   14 CONTINUE
      RETURN
103   FORMAT('BOUND FOR Z0',I3,' CANNOT BE FOUND')
      END
CDECK  ID>, CPOLYZD.
      SUBROUTINE CPOLYZ(C,N,MAXIT,Z0,H)
C
      CHARACTER NAME*(*)
      PARAMETER (NAME = 'CPOLYZ')
      CALL MTLPRT(NAME,'C209.0','Not available on this machine')
      RETURN
      END
CDECK  ID>, NZERFZ64.   
      FUNCTION NZERFZ(F,ZP,N)
C
      IMPLICIT COMPLEX*16 (A-H,I,O-Z)
C
      CHARACTER*(*) NAME
      PARAMETER(NAME='NZERFZ')
      DOUBLE PRECISION
     + W,X,R,EPS,CST,CONST,R1,HF
      DIMENSION ZP(*),W(12),X(12)

      PARAMETER (PI = 3.14159 26535 89793 24D0)
      PARAMETER (I = (0D0,1D0))
      PARAMETER ( CPI2 = 2*PI*I)
      PARAMETER (R1 = 1, HF = R1/2, DZ = (1+I)*1D-8)
      PARAMETER (EPS = 1D-4, CST = 0.005D0, NFMAX = 200000)

      DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
      DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
      DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
      DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
      DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
      DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
      DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
      DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
      DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
      DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
      DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
      DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/

      H=0
      DO 10 J = 1,N
      NF=0
      A=ZP(J)
      IF(J .LT. N) THEN
       B=ZP(J+1)
      ELSE
       B=ZP(1)
      ENDIF
      IF(B .EQ. A) GO TO 10
      CONST=CST/ABS(B-A)
      BB=A
    1 AA=BB
      BB=B
    2 C1=HF*(BB+AA)
      C2=HF*(BB-AA)
      S8=0
      DO 3 K = 1,4
      U=C2*X(K)
      FPP=F(C1+U+DZ)
      FPM=F(C1+U-DZ)
      FMP=F(C1-U+DZ)
      FMM=F(C1-U-DZ)
    3 S8=S8+W(K)*(((FPP-FPM)/DZ)/(FPP+FPM)+((FMP-FMM)/DZ)/(FMP+FMM))
      S16=0
      DO 4 K = 5,12
      U=C2*X(K)
      FPP=F(C1+U+DZ)
      FPM=F(C1+U-DZ)
      FMP=F(C1-U+DZ)
      FMM=F(C1-U-DZ)
    4 S16=S16+W(K)*(((FPP-FPM)/DZ)/(FPP+FPM)+((FMP-FMM)/DZ)/(FMP+FMM))
      S16=C2*S16
      NF=NF+48
      IF(ABS(S16-C2*S8) .LE. EPS*(1+ABS(S16))) THEN
       H=H+S16
       IF(BB .NE. B) GO TO 1
      ELSE
       BB=C1
       IF(1+CONST*ABS(C2) .NE. 1 .AND. NF .LE. NFMAX) GO TO 2
       R=0
       CALL MTLPRT(NAME,'C210.1','PROBLEMS WITH INTEGRATION,'//
     +             'POLYGON TOO NEAR TO A ZERO OR SINGULARITY ?')
       GO TO 99
      ENDIF
   10 CONTINUE
      R=H/CPI2
   99 NZERFZ=NINT(ABS(R))
      RETURN
      END
CDECK  ID>, ERF.
      FUNCTION ERF(X)

      LOGICAL LEF
      DIMENSION P2(0:4),Q2(0:4)

      PARAMETER(Z1 = 1, HF = Z1/2, C1 = 0.56418 958)

      DATA P10,Q10,P11 /+3.67678 77, +3.25845 93, -9.79704 65E-2/

      DATA (P2(I),Q2(I),I=0,4)
     +/+7.37388 83E+0, +7.37396 09E+0, +6.86501 85E+0, +1.51849 08E+1,
     1 +3.03179 93E+0, +1.27955 30E+1, +5.63169 62E-1, +5.35421 68E+0,
     2 +4.31877 87E-5, +1/

      DATA P30,Q30,P31 /-1.24368 54E-1, +4.40917 06E-1, -9.68210 36E-2/

      LEF=.TRUE.
      GO TO 9

      ENTRY ERFC(X)
      LEF=.FALSE.

    9 V=ABS(X)
      IF(V .LT. HF) THEN
       Y=V**2
       H=X*(P10+P11*Y)/(Q10+Y)
       HC=1-H
      ELSE
       IF(V .LT. 4) THEN
        AP=P2(4)
        AQ=Q2(4)
        DO 2 I = 3,0,-1
        AP=P2(I)+V*AP
    2   AQ=Q2(I)+V*AQ
        HC=EXP(-V**2)*AP/AQ
        H=1-HC
       ELSE
        Y=1/V**2
        HC=EXP(-V**2)*(C1+Y*(P30+P31*Y)/(Q30+Y))/V
        H=1-HC
       ENDIF
       IF(X .LT. 0) THEN
        H=-H
        HC=2-HC
       ENDIF
      ENDIF
      IF(LEF) THEN
       ERF=H
      ELSE
       ERFC=HC
      ENDIF
      RETURN
      END
CDECK  ID>, ERF64.  
      FUNCTION DERF(X)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      CHARACTER*(*) NAME
      PARAMETER(NAME='DERF')
C
      LOGICAL LEF
      DIMENSION P1(0:3),Q1(0:3),P2(0:7),Q2(0:7),P3(0:4),Q3(0:4)

      PARAMETER(Z1 = 1, HF = Z1/2, C1 = 0.56418 95835 47756 29D0)

      DATA (P1(I),Q1(I),I=0,3)
     +/+2.42667 95523 05317 5D+2, +2.15058 87586 98612 0D+2,
     1 +2.19792 61618 29415 2D+1, +9.11649 05404 51490 1D+1,
     2 +6.99638 34886 19135 5D+0, +1.50827 97630 40778 7D+1,
     3 -3.56098 43701 81538 5D-2, +1/

      DATA (P2(I),Q2(I),I=0,7)
     +/+3.00459 26102 01616 01D+2, +3.00459 26095 69832 93D+2,
     1 +4.51918 95371 18729 42D+2, +7.90950 92532 78980 27D+2,
     2 +3.39320 81673 43436 87D+2, +9.31354 09485 06096 21D+2,
     3 +1.52989 28504 69404 04D+2, +6.38980 26446 56311 67D+2,
     4 +4.31622 27222 05673 53D+1, +2.77585 44474 39876 43D+2,
     5 +7.21175 82508 83093 66D+0, +7.70001 52935 22947 30D+1,
     6 +5.64195 51747 89739 71D-1, +1.27827 27319 62942 35D+1,
     7 -1.36864 85738 27167 07D-7, +1/

      DATA (P3(I),Q3(I),I=0,4)
     +/-2.99610 70770 35421 74D-3, +1.06209 23052 84679 18D-2,
     1 -4.94730 91062 32507 34D-2, +1.91308 92610 78298 41D-1,
     2 -2.26956 59353 96869 30D-1, +1.05167 51070 67932 07D+0,
     3 -2.78661 30860 96477 88D-1, +1.98733 20181 71352 56D+0,
     4 -2.23192 45973 41846 86D-2, +1/

      LEF=.TRUE.
      GO TO 9

      ENTRY DERFC(X)
      LEF=.FALSE.

    9 V=ABS(X)
      IF(V .LT. HF) THEN
       Y=V**2
       AP=P1(3)
       AQ=Q1(3)
       DO 1 I = 2,0,-1
       AP=P1(I)+Y*AP
    1  AQ=Q1(I)+Y*AQ
       H=X*AP/AQ
       HC=1-H
      ELSE
       IF(V .LT. 4) THEN
        AP=P2(7)
        AQ=Q2(7)
        DO 2 I = 6,0,-1
        AP=P2(I)+V*AP
    2   AQ=Q2(I)+V*AQ
        HC=EXP(-V**2)*AP/AQ
        H=1-HC
       ELSE
        Y=1/V**2
        AP=P3(4)
        AQ=Q3(4)
        DO 3 I = 3,0,-1
        AP=P3(I)+Y*AP
    3   AQ=Q3(I)+Y*AQ
        HC=EXP(-V**2)*(C1+Y*AP/AQ)/V
        H=1-HC
       ENDIF
       IF(X .LT. 0) THEN
        H=-H
        HC=2-HC
       ENDIF
      ENDIF
      IF(LEF) THEN
       DERF=H
      ELSE
       DERFC=HC
      ENDIF
      RETURN
      END
CDECK  ID>, FREQ.   
      FUNCTION FREQ(X)

      DIMENSION P2(0:4),Q2(0:4)

      PARAMETER(Z1 = 1, HF = Z1/2)
      PARAMETER(C1 = 0.56418 958, W2 = 1.41421 356, RW2 = 1/W2)

      DATA P10,Q10,P11 /+3.67678 77, +3.25845 93, -9.79704 65E-2/

      DATA (P2(I),Q2(I),I=0,4)
     +/+7.37388 83E+0, +7.37396 09E+0, +6.86501 85E+0, +1.51849 08E+1,
     1 +3.03179 93E+0, +1.27955 30E+1, +5.63169 62E-1, +5.35421 68E+0,
     2 +4.31877 87E-5, +1/

      DATA P30,Q30,P31 /-1.24368 54E-1, +4.40917 06E-1, -9.68210 36E-2/

      V=RW2*ABS(X)
      IF(V .LT. HF) THEN
       Y=V**2
       H=V*(P10+P11*Y)/(Q10+Y)
       HC=1-H
      ELSEIF(V .LT. 4) THEN
       AP=P2(4)
       AQ=Q2(4)
       DO 2 I = 3,0,-1
       AP=P2(I)+V*AP
    2  AQ=Q2(I)+V*AQ
       HC=EXP(-V**2)*AP/AQ
       H=1-HC
      ELSE
       Y=1/V**2
       HC=EXP(-V**2)*(C1+Y*(P30+P31*Y)/(Q30+Y))/V
       H=1-HC
      ENDIF
      IF(X .GT. 0) THEN
       FREQ=HF+HF*H
      ELSE
       FREQ=HF*HC
      ENDIF
      RETURN
      END
CDECK  ID>, FREQ64. 
      FUNCTION DFREQ(X)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      CHARACTER*(*) NAME
      PARAMETER(NAME='DFREQ')
C
      DIMENSION P1(0:3),Q1(0:3),P2(0:7),Q2(0:7),P3(0:4),Q3(0:4)

      PARAMETER(Z1 = 1, HF = Z1/2)
      PARAMETER(C1 = 0.56418 95835 47756 29D0)
      PARAMETER(W2 = 1.41421 35623 73095 05D0, RW2 = 1/W2)

      DATA (P1(I),Q1(I),I=0,3)
     +/+2.42667 95523 05317 5D+2, +2.15058 87586 98612 0D+2,
     1 +2.19792 61618 29415 2D+1, +9.11649 05404 51490 1D+1,
     2 +6.99638 34886 19135 5D+0, +1.50827 97630 40778 7D+1,
     3 -3.56098 43701 81538 5D-2, +1/

      DATA (P2(I),Q2(I),I=0,7)
     +/+3.00459 26102 01616 01D+2, +3.00459 26095 69832 93D+2,
     1 +4.51918 95371 18729 42D+2, +7.90950 92532 78980 27D+2,
     2 +3.39320 81673 43436 87D+2, +9.31354 09485 06096 21D+2,
     3 +1.52989 28504 69404 04D+2, +6.38980 26446 56311 67D+2,
     4 +4.31622 27222 05673 53D+1, +2.77585 44474 39876 43D+2,
     5 +7.21175 82508 83093 66D+0, +7.70001 52935 22947 30D+1,
     6 +5.64195 51747 89739 71D-1, +1.27827 27319 62942 35D+1,
     7 -1.36864 85738 27167 07D-7, +1/

      DATA (P3(I),Q3(I),I=0,4)
     +/-2.99610 70770 35421 74D-3, +1.06209 23052 84679 18D-2,
     1 -4.94730 91062 32507 34D-2, +1.91308 92610 78298 41D-1,
     2 -2.26956 59353 96869 30D-1, +1.05167 51070 67932 07D+0,
     3 -2.78661 30860 96477 88D-1, +1.98733 20181 71352 56D+0,
     4 -2.23192 45973 41846 86D-2, +1/

      V=RW2*ABS(X)
      IF(V .LT. HF) THEN
       Y=V**2
       AP=P1(3)
       AQ=Q1(3)
       DO 1 I = 2,0,-1
       AP=P1(I)+Y*AP
    1  AQ=Q1(I)+Y*AQ
       H=V*AP/AQ
       HC=1-H
      ELSEIF(V .LT. 4) THEN
       AP=P2(7)
       AQ=Q2(7)
       DO 2 I = 6,0,-1
       AP=P2(I)+V*AP
    2  AQ=Q2(I)+V*AQ
       HC=EXP(-V**2)*AP/AQ
       H=1-HC
      ELSE
       Y=1/V**2
       AP=P3(4)
       AQ=Q3(4)
       DO 3 I = 3,0,-1
       AP=P3(I)+Y*AP
    3  AQ=Q3(I)+Y*AQ
       HC=EXP(-V**2)*(C1+Y*AP/AQ)/V
       H=1-HC
      ENDIF
      IF(X .GT. 0) THEN
       DFREQ=HF+HF*H
      ELSE
       DFREQ=HF*HC
      ENDIF
      RETURN
      END
CDECK  ID>, GAMMA.  
      FUNCTION GAMMA(X)
      DOUBLE PRECISION DGAMMA,D

      SROUND(D)=D+(D-SNGL(D))
      GAMMA=SROUND(DGAMMA(DBLE(X)))
      RETURN
      END
CDECK  ID>, GAMMA64.
      FUNCTION DGAMMA(X)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      CHARACTER*(*) NAME
      PARAMETER(NAME='GAMMA/DGAMMA')
C
      CHARACTER*80 ERRTXT

      DIMENSION C(0:15)

      DATA C( 0) /3.65738 77250 83382 44D0/
      DATA C( 1) /1.95754 34566 61268 27D0/
      DATA C( 2) /0.33829 71138 26160 39D0/
      DATA C( 3) /0.04208 95127 65575 49D0/
      DATA C( 4) /0.00428 76504 82129 09D0/
      DATA C( 5) /0.00036 52121 69294 62D0/
      DATA C( 6) /0.00002 74006 42226 42D0/
      DATA C( 7) /0.00000 18124 02333 65D0/
      DATA C( 8) /0.00000 01096 57758 66D0/
      DATA C( 9) /0.00000 00059 87184 05D0/
      DATA C(10) /0.00000 00003 07690 81D0/
      DATA C(11) /0.00000 00000 14317 93D0/
      DATA C(12) /0.00000 00000 00651 09D0/
      DATA C(13) /0.00000 00000 00025 96D0/
      DATA C(14) /0.00000 00000 00001 11D0/
      DATA C(15) /0.00000 00000 00000 04D0/

      U=X
      IF(U .LE. 0) THEN
       WRITE(ERRTXT,101) U
       CALL MTLPRT(NAME,'C302.1',ERRTXT)
       H=0
       GO TO 9
      ENDIF
    8 F=1
      IF(U .LT. 3) THEN
       DO 1 I = 1,INT(4-U)
       F=F/U
    1  U=U+1
      ELSE
       DO 2 I = 1,INT(U-3)
       U=U-1
    2  F=F*U
      END IF
      H=U+U-7
      ALFA=H+H
      B1=0
      B2=0
      DO 3 I = 15,0,-1
      B0=C(I)+ALFA*B1-B2
      B2=B1
    3 B1=B0
    9 DGAMMA=F*(B0-H*B2)
      RETURN
  101 FORMAT('ARGUMENT IS NEGATIVE = ',1P,E15.1)
      END
CDECK  ID>, GAMMF.  
      FUNCTION GAMMF(X)
      DOUBLE PRECISION DGAMMF,D

      SROUND(D)=D+(D-SNGL(D))
      GAMMF=SROUND(DGAMMF(DBLE(X)))
      RETURN
      END
CDECK  ID>, GAMMF64.
      FUNCTION DGAMMF(X)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      CHARACTER*(*) NAME
      PARAMETER(NAME='GAMMF/DGAMMF')
      CHARACTER*80 ERRTXT
C
      DIMENSION C(0:15)

      PARAMETER (PI = 3.14159 26535 89793 24D0)

      DATA C( 0) /3.65738 77250 83382 44D0/
      DATA C( 1) /1.95754 34566 61268 27D0/
      DATA C( 2) /0.33829 71138 26160 39D0/
      DATA C( 3) /0.04208 95127 65575 49D0/
      DATA C( 4) /0.00428 76504 82129 09D0/
      DATA C( 5) /0.00036 52121 69294 62D0/
      DATA C( 6) /0.00002 74006 42226 42D0/
      DATA C( 7) /0.00000 18124 02333 65D0/
      DATA C( 8) /0.00000 01096 57758 66D0/
      DATA C( 9) /0.00000 00059 87184 05D0/
      DATA C(10) /0.00000 00003 07690 81D0/
      DATA C(11) /0.00000 00000 14317 93D0/
      DATA C(12) /0.00000 00000 00651 09D0/
      DATA C(13) /0.00000 00000 00025 96D0/
      DATA C(14) /0.00000 00000 00001 11D0/
      DATA C(15) /0.00000 00000 00000 04D0/

      U=X
      IF(U .LE. 0) THEN
       IF(U .EQ. INT(X)) THEN
        WRITE(ERRTXT,101) U
        CALL MTLPRT(NAME,'C303.1',ERRTXT)
        H=0
        GO TO 9
       ELSE
        U=1-X
       END IF
      ENDIF
    8 F=1
      IF(U .LT. 3) THEN
       DO 1 I = 1,INT(4-U)
       F=F/U
    1  U=U+1
      ELSE
       DO 2 I = 1,INT(U-3)
       U=U-1
    2  F=F*U
      END IF
      H=U+U-7
      ALFA=H+H
      B1=0
      B2=0
      DO 3 I = 15,0,-1
      B0=C(I)+ALFA*B1-B2
      B2=B1
    3 B1=B0
      H=F*(B0-H*B2)
      IF(X .LT. 0) H=PI/(SIN(PI*X)*H)
    9 DGAMMF=H
      RETURN

  101 FORMAT('ARGUMENT IS NON-POSITIVE INTEGER = ',1P,E15.1)
      END
CDECK  ID>, ALGAMA. 
      FUNCTION ALGAMA(X)
      DOUBLE PRECISION DLGAMA,D

      ENTRY ALOGAM(X)

      SROUND(D)=D+(D-SNGL(D))
      ALGAMA=SROUND(DLGAMA(DBLE(X)))
      RETURN
      END
CDECK  ID>, ALGAMA64.   
      FUNCTION DLGAMA(X)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      CHARACTER*(*) NAME
      PARAMETER(NAME='ALGAMA/DLGAMA')
C
      DIMENSION P1(7),Q1(7),P2(7),Q2(7),P3(7),Q3(7),C(5)

      PARAMETER (Z1 = 1, HF = Z1/2, HF1 = 1+HF)
      CHARACTER*80 ERRTXT
      DATA P1
     1/+3.84287 36567 45991D+0, +5.27068 93753 00983D+1,
     2 +5.55840 45723 51531D+1, -2.15135 13573 72570D+2,
     3 -2.45872 61722 29242D+2, -5.75008 93603 04123D+1,
     4 -2.33590 98949 51284D+0/
      DATA Q1
     1/+1.00000 00000 00000D+0, +3.37330 47907 07074D+1,
     2 +1.93877 84034 37713D+2, +3.08829 54973 42428D+2,
     3 +1.50068 39064 89095D+2, +2.01068 51344 33395D+1,
     4 +4.57174 20282 50299D-1/
      DATA P2
     1/+4.87402 01396 83863 6D+0, +2.48845 25168 57407 6D+2,
     2 +2.17973 66058 89591 5D+3, +3.79751 24011 52511 8D+3,
     3 -1.97780 70769 84164 6D+3, -3.69298 34005 59128 2D+3,
     4 -5.60177 73537 80387 7D+2/
      DATA Q2
     1/+1.00000 00000 00000 0D+0, +9.50999 17418 20893 8D+1,
     2 +1.56120 45277 92863 5D+3, +7.23400 87928 94807 1D+3,
     3 +1.04595 76594 05895 9D+4, +4.16994 15153 20023 1D+3,
     4 +2.76785 83623 80410 1D+2/
      DATA P3
     1/-6.88062 40094 59425D+3, -4.30699 69819 57098D+5,
     2 -4.75045 94653 43956D+6, -2.94234 45930 32234D+6,
     3 +3.63218 04931 54257D+7, -3.35677 82814 54576D+6,
     4 -2.48043 69488 28593D+7/
      DATA Q3
     1/+1.00000 00000 00000D+0, -1.42168 29839 65146D+3,
     2 -1.55528 90280 85353D+5, -3.41525 17108 01107D+6,
     3 -2.09696 23255 80444D+7, -3.45441 75093 34395D+7,
     4 -9.16055 82863 71317D+6/
      DATA C
     1/ 1.12249 21356 561D-1,  7.95916 92961 204D-2,
     1 -1.70877 94611 020D-3,  9.18938 53320 467D-1,
     2  1.34699 05627 879D+0/


      ENTRY DLOGAM(X)

      IF(X .LE. 0) THEN
       H=0
       WRITE(ERRTXT,101) X
       CALL MTLPRT(NAME,'C304.1',ERRTXT)
      ELSE IF(X .EQ. 1 .OR. X .EQ. 2) THEN
       H=0
      ELSE IF(X .LE. HF) THEN
       Y=X+1
       AP=P1(1)
       AQ=Q1(1)
       DO 2 I = 2,7
       AP=P1(I)+Y*AP
    2  AQ=Q1(I)+Y*AQ
       H=-LOG(X)+X*AP/AQ
      ELSE IF(X .LE. HF1) THEN
       AP=P1(1)
       AQ=Q1(1)
       DO 3 I = 2,7
       AP=P1(I)+X*AP
    3  AQ=Q1(I)+X*AQ
       H=(X-1)*AP/AQ
      ELSE IF(X .LE. 4) THEN
       AP=P2(1)
       AQ=Q2(1)
       DO 4 I = 2,7
       AP=P2(I)+X*AP
    4  AQ=Q2(I)+X*AQ
       H=(X-2)*AP/AQ
      ELSE IF(X .LE. 12) THEN
       AP=P3(1)
       AQ=Q3(1)
       DO 5 I = 2,7
       AP=P3(I)+X*AP
    5  AQ=Q3(I)+X*AQ
       H=AP/AQ
      ELSE
       Y=1/X**2
       H=(X-HF)*LOG(X)-X+C(4)+(C(1)+Y*(C(2)+Y*C(3)))/
     1                                        ((C(5)+Y)*X)
      ENDIF
      DLGAMA=H
      RETURN
  101 FORMAT('NON-POSITIVE ARGUMENT  X = ',1P,E15.6)
      END
CDECK  ID>, CGAMMA. 
      FUNCTION CGAMMA(Z)
      COMPLEX CGAMMA,Z
      COMPLEX*16
     + WGAMMA,W
      DOUBLE PRECISION
     + D
      DOUBLE PRECISION
     +      GREAL,GIMAG,XARG,YARG
      COMPLEX*16
     +      ZARG,GCONJG,GCMPLX
      GREAL( ZARG)=DREAL( ZARG)
      GIMAG( ZARG)=DIMAG( ZARG)
      GCONJG(ZARG)=DCONJG(ZARG)
      GCMPLX(XARG,YARG)=DCMPLX(XARG,YARG)
      SROUND(D)=D+(D-SNGL(D))
      W=Z
      W=WGAMMA(W)
      CGAMMA=CMPLX(SROUND(GREAL(W)),SROUND(GIMAG(W)))
      RETURN
      END
CDECK  ID>, CGAMMA64.   
      FUNCTION WGAMMA(Z)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMPLEX*16
     +  WGAMMA
      COMPLEX*16
     +       Z,U,V,F,H,S
      CHARACTER NAME*(*)
      CHARACTER*80 ERRTXT
      PARAMETER (NAME = 'CGAMMA/WGAMMA')
      DIMENSION C(0:15)

      PARAMETER (Z1 = 1, HF = Z1/2)


      DATA PI /3.14159 26535 89793 24D0/
      DATA C1 /2.50662 82746 31000 50D0/

      DATA C( 0) / 41.62443 69164 39068D0/
      DATA C( 1) /-51.22424 10223 74774D0/
      DATA C( 2) / 11.33875 58134 88977D0/
      DATA C( 3) / -0.74773 26877 72388D0/
      DATA C( 4) /  0.00878 28774 93061D0/
      DATA C( 5) / -0.00000 18990 30264D0/
      DATA C( 6) /  0.00000 00019 46335D0/
      DATA C( 7) / -0.00000 00001 99345D0/
      DATA C( 8) /  0.00000 00000 08433D0/
      DATA C( 9) /  0.00000 00000 01486D0/
      DATA C(10) / -0.00000 00000 00806D0/
      DATA C(11) /  0.00000 00000 00293D0/
      DATA C(12) / -0.00000 00000 00102D0/
      DATA C(13) /  0.00000 00000 00037D0/
      DATA C(14) / -0.00000 00000 00014D0/
      DATA C(15) /  0.00000 00000 00006D0/

      DOUBLE PRECISION
     +      GREAL,GIMAG,XARG,YARG
      COMPLEX*16
     +      ZARG,GCONJG,GCMPLX
      GREAL( ZARG)=DREAL( ZARG)
      GIMAG( ZARG)=DIMAG( ZARG)
      GCONJG(ZARG)=DCONJG(ZARG)
      GCMPLX(XARG,YARG)=DCMPLX(XARG,YARG)

      U=Z
      X=U
      IF(GIMAG(U) .EQ. 0 .AND. -ABS(X) .EQ. INT(X)) THEN
       F=0
       H=0
       WRITE(ERRTXT,101) X
       CALL MTLPRT(NAME,'C305.1',ERRTXT)
      ELSE
       IF(X .GE. 1) THEN
        F=1
        V=U
       ELSEIF(X .GE. 0) THEN
        F=1/U
        V=1+U
       ELSE
        F=1
        V=1-U
       END IF
       H=1
       S=C(0)
       DO 1 K = 1,15
       H=((V-K)/(V+(K-1)))*H
    1  S=S+C(K)*H
       H=V+(4+HF)
       H=C1*EXP((V-HF)*LOG(H)-H)*S
       IF(X .LT. 0) H=PI/(SIN(PI*U)*H)
      ENDIF
      WGAMMA=F*H
      RETURN
  101 FORMAT('ARGUMENT EQUALS NON-POSITIVE INTEGER = ',1P,E15.1)
      END
CDECK  ID>, CLOGAM. 
      FUNCTION CLGAMA(Z)
      COMPLEX CLGAMA,Z
      COMPLEX CLOGAM
      COMPLEX*16
     +     WLGAMA,W
      DOUBLE PRECISION
     +     D

      SROUND(D)=D+(D-SNGL(D))

      ENTRY CLOGAM(Z)

      W=Z
      W=WLGAMA(W)
      CLGAMA=CMPLX(SROUND(DREAL(W)),SROUND(DIMAG(W)))
      RETURN
      END
CDECK  ID>, CLOGAM64.   
      FUNCTION WLGAMA(Z)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMPLEX*16
     +     WLGAMA
     +    ,WLOGAM
      COMPLEX*16
C    +     Z,W,U,V,H,P,R,GCONJG,GCMPLX
     +     Z,  U,V,H,P,R
      CHARACTER NAME*(*)
      CHARACTER*80 ERRTXT
      PARAMETER (NAME = 'CLGAMA/WLGAMA')
      DIMENSION C(10)

      PARAMETER (Z1 = 1, HF = Z1/2)

      DOUBLE PRECISION
     +      GREAL,GIMAG,XARG,YARG
      COMPLEX*16
     +      ZARG,GCONJG,GCMPLX
      GREAL( ZARG)=DREAL( ZARG)
      GIMAG( ZARG)=DIMAG( ZARG)
      GCONJG(ZARG)=DCONJG(ZARG)
      GCMPLX(XARG,YARG)=DCMPLX(XARG,YARG)

      DATA PI /3.14159 26535 89793 24D+0/
      DATA C1 /9.18938 53320 46727 42D-1/
      DATA C2 /1.14472 98858 49400 17D+0/

      DATA C( 1) / 8.33333 33333 33333 33D-2/
      DATA C( 2) /-2.77777 77777 77777 78D-3/
      DATA C( 3) / 7.93650 79365 07936 51D-4/
      DATA C( 4) /-5.95238 09523 80952 38D-4/
      DATA C( 5) / 8.41750 84175 08417 51D-4/
      DATA C( 6) /-1.91752 69175 26917 53D-3/
      DATA C( 7) / 6.41025 64102 56410 26D-3/
      DATA C( 8) /-2.95506 53594 77124 18D-2/
      DATA C( 9) / 1.79644 37236 88305 73D-1/
      DATA C(10) /-1.39243 22169 05901 12D+0/
C     GREAL(U)=DREAL(U)
C     GIMAG(U)=DIMAG(U)
C     GCONJG(U)=DCONJG(U)
C     GCMPLX(X,Y)=DCMPLX(X,Y)

      ENTRY WLOGAM(Z)

      X=Z
      Y=GIMAG(Z)
      IF(Y .EQ. 0 .AND. -ABS(X) .EQ. INT(X)) THEN
       H=0
       WRITE(ERRTXT,101) X
       CALL MTLPRT(NAME,'C306.1',ERRTXT)
      ELSE
       YA=ABS(Y)
       U=GCMPLX(X,YA)
       IF(X .LT. 0) U=1-U
       H=0
       UR=U
       IF(UR .LT. 7) THEN
        UI=GIMAG(U)
        A=ATAN2(UI,UR)
        H=U
        DO 1 I = 1,6-INT(UR)
        UR=UR+1
        U=GCMPLX(UR,UI)
        H=H*U
    1   A=A+ATAN2(UI,UR)
        H=GCMPLX(HF*LOG(GREAL(H)**2+GIMAG(H)**2),A)
        U=U+1
       ENDIF
       R=1/U**2
       P=R*C(10)
       DO 2 I = 9,2,-1
    2  P=R*(C(I)+P)
       H=C1+(U-HF)*LOG(U)-U+(C(1)+P)/U-H
       IF(X .LT. 0) THEN
        UR=INT(X)-1
        UI=PI*(X-UR)
        X=PI*YA
        T=EXP(-X-X)
        A=SIN(UI)
        T=X+HF*LOG(T*A**2+(HF*(1-T))**2)
        A=ATAN2(COS(UI)*TANH(X),A)-UR*PI
        H=C2-GCMPLX(T,A)-H
       ENDIF
       IF(Y .LT. 0) H=GCONJG(H)
      ENDIF
      WLGAMA=H
      RETURN
  101 FORMAT('ARGUMENT EQUALS NON-POSITIVE INTEGER = ',1P,E15.1)
      END
CDECK  ID>, CDIGAM. 
      FUNCTION CDIGAM(Z)
      COMPLEX CDIGAM,Z
      COMPLEX*16
     + WDIGAM,W
      DOUBLE PRECISION
     +  D

      DOUBLE PRECISION
     +      GREAL,GIMAG,XARG,YARG
      COMPLEX*16
     +      ZARG,GCONJG,GCMPLX
      GREAL( ZARG)=DREAL( ZARG)
      GIMAG( ZARG)=DIMAG( ZARG)
      GCONJG(ZARG)=DCONJG(ZARG)
      GCMPLX(XARG,YARG)=DCMPLX(XARG,YARG)
      SROUND(D)=D+(D-SNGL(D))
      W=Z
      W=WDIGAM(W)
      CDIGAM=CMPLX(SROUND(GREAL(W)),SROUND(GIMAG(W)))
      RETURN
      END
CDECK  ID>, CDIGAM64.   
      FUNCTION WDIGAM(Z)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMPLEX*16
     +   WDIGAM
      COMPLEX*16
     + Z,U,V,H,R,P
      CHARACTER NAME*(*)
      CHARACTER*80 ERRTXT
      PARAMETER (NAME = 'CDIGAM/WDIGAM')
      DIMENSION C(6)

      PARAMETER (Z1 = 1, HF = Z1/2)
      PARAMETER (PI = 3.14159 26535 89793 24D0)

      DOUBLE PRECISION
     +      GREAL,GIMAG,XARG,YARG
      COMPLEX*16
     +      ZARG,GCONJG,GCMPLX
      GREAL( ZARG)=DREAL( ZARG)
      GIMAG( ZARG)=DIMAG( ZARG)
      GCONJG(ZARG)=DCONJG(ZARG)
      GCMPLX(XARG,YARG)=DCMPLX(XARG,YARG)
CSEQ,GCMPLX.

      DATA C(1) / 8.33333 33333 33333 33D-2/
      DATA C(2) /-8.33333 33333 33333 33D-3/
      DATA C(3) / 3.96825 39682 53968 25D-3/
      DATA C(4) /-4.16666 66666 66666 67D-3/
      DATA C(5) / 7.57575 75757 57575 76D-3/
      DATA C(6) /-2.10927 96092 79609 28D-2/

      U=Z
      X=U
      A=ABS(X)
      IF(GIMAG(U) .EQ. 0 .AND. -A .EQ. INT(X)) THEN
       H=0
       WRITE(ERRTXT,101) X
       CALL MTLPRT(NAME,'C307.1',ERRTXT)
      ELSE
       IF(X .LT. 0) U=-U
       V=U
       H=0
       IF(A .LT. 15) THEN
        H=1/V
        DO 1 I = 1,14-INT(A)
        V=V+1
    1   H=H+1/V
        V=V+1
       END IF
       R=1/V**2
       P=R*C(1)
       DO 2 I = 6,1,-1
    2  P=R*(C(I)+P)
       H=LOG(V)-HF/V-P-H
       IF(X .LT. 0) THEN
        V=PI*U
        X=V
        A=SIN(X)
        X=COS(X)
        Y=TANH(GIMAG(V))
        H=H+1/U+PI*GCMPLX(X,-A*Y)/GCMPLX(A,X*Y)
       END IF
      ENDIF
      WDIGAM=H
      RETURN
  101 FORMAT(1X,'ARGUMENT EQUALS NON-POSITIVE INTEGER = ',1P,E15.1)
      END
CDECK  ID>, WCLBES. 
      SUBROUTINE WCLBES(ZZ,ETA1,ZLMIN,NL,FC,GC,FCP,GCP,SIG,KFN,MODE1,
     1                  IFAIL,IPR)
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C  COMPLEX COULOMB WAVEFUNCTION PROGRAM USING STEED'S METHOD           C
C  Original title : COULCC                                             C
C                                                                      C
C  A. R. Barnett           Manchester  March   1981                    C
C  modified I.J. Thompson  Daresbury, Sept. 1983 for Complex Functions C
C                                                                      C
C  The FORM (not the SUBSTANCE) of this program has been modified      C
C   by K.S. KOLBIG (CERN)    December 1987                             C
C                                                                      C
C  original program  RCWFN       in    CPC  8 (1974) 377-395           C
C                 +  RCWFF       in    CPC 11 (1976) 141-142           C
C                 +  COULFG      in    CPC 27 (1982) 147-166           C
C  description of real algorithm in    CPC 21 (1981) 297-314           C
C  description of complex algorithm    JCP 64 (1986) 490-509           C
C  this version written up       in    CPC 36 (1985) 363-372           C
C                                                                      C
C  WCLBES returns F,G,G',G',SIG for complex ETA, ZZ, and ZLMIN,        C
C   for NL integer-spaced lambda values ZLMIN to ZLMIN+NL inclusive,   C
C   thus giving  complex-energy solutions to the Coulomb Schrodinger   C
C   equation,to the Klein-Gordon equation and to suitable forms of     C
C   the Dirac equation ,also spherical & cylindrical Bessel equations  C
C                                                                      C
C  if ABS(MODE1)                                                       C
C            = 1  get F,G,F',G'   for integer-spaced lambda values     C
C            = 2      F,G      unused arrays must be dimensioned in    C
C            = 3      F,  F'          call to at least length (0:1)    C
C            = 4      F                                                C
C            = 11 get F,H+,F',H+' ) if KFN=0, H+ = G + i.F        )    C
C            = 12     F,H+        )       >0, H+ = J + i.Y = H(1) ) in C
C            = 21 get F,H-,F',H-' ) if KFN=0, H- = G - i.F        ) GC C
C            = 22     F,H-        )       >0, H- = J - i.Y = H(2) )    C
C                                                                      C
C     if MODE1 < 0 then the values returned are scaled by an exponen-  C
C                  tial factor (dependent only on ZZ) to bring nearer  C
C                  unity the functions for large ABS(ZZ), small ETA ,  C
C                  and ABS(ZL) < ABS(ZZ).                              C
C        Define SCALE = (  0        if MODE1 > 0                       C
C                       (  IMAG(ZZ) if MODE1 < 0  &  KFN < 3           C
C                       (  REAL(ZZ) if MODE1 < 0  &  KFN = 3           C
C        then FC = EXP(-ABS(SCALE)) * ( F, j, J, or I)                 C
C         and GC = EXP(-ABS(SCALE)) * ( G, y, or Y )                   C
C               or EXP(SCALE)       * ( H+, H(1), or K)                C
C               or EXP(-SCALE)      * ( H- or H(2) )                   C
C                                                                      C
C  if  KFN  =  0,-1  complex Coulomb functions are returned   F & G    C
C           =  1   spherical Bessel      "      "     "       j & y    C
C           =  2 cylindrical Bessel      "      "     "       J & Y    C
C           =  3 modified cyl. Bessel    "      "     "       I & K    C
C                                                                      C
C          and where Coulomb phase shifts put in SIG if KFN=0 (not -1) C
C                                                                      C
C  The use of MODE and KFN is independent                              C
C    (except that for KFN=3,  H(1) & H(2) are not given)               C
C                                                                      C
C  With negative orders lambda, WCLBES can still be used but with      C
C    reduced accuracy as CF1 becomes unstable. The user is thus        C
C    strongly advised to use reflection formulae based on              C
C    H+-(ZL,,) = H+-(-ZL-1,,) * exp +-i(sig(ZL)-sig(-ZL-1)-(ZL+1/2)pi) C
C                                                                      C
C  Precision:  results to within 2-3 decimals of 'machine accuracy',   C
C              except in the following cases:                          C
C              (1) if CF1A fails because X too small or ETA too large  C
C               the F solution  is less accurate if it decreases with  C
C               decreasing lambda (e.g. for lambda.LE.-1 & ETA.NE.0)   C
C              (2) if ETA is large (e.g. >> 50) and X inside the       C
C                turning point, then progressively less accuracy       C
C              (3) if ZLMIN is around sqrt(ACCUR) distance from an     C
C               integral order and abs(X) << 1, then errors present.   C
C               RERR traces the main roundoff errors.                  C
C                                                                      C
C   WCLBES is coded for real*8 on IBM or equivalent  ACCUR >= 10**-14  C
C          with a section of doubled REAL*16 for less roundoff errors. C
C          (If no doubled precision available, increase JMAX to eg 100)C
C   Use IMPLICIT COMPLEX*32 & REAL*16 on VS compiler ACCUR >= 10**-32  C
C   For single precision CDC (48 bits) reassign                        C
C        DOUBLE PRECISION=REAL etc.                                    C
C                                                                      C
C   IPR    on input   = 0 : no printing of error messages              C
C                    ne 0 : print error messages on file 6             C
C   IFAIL  in output = -2 : argument out of range                      C
C                    = -1 : one of the continued fractions failed,     C
C                           or arithmetic check before final recursion C
C                    =  0 : All Calculations satisfactory              C
C                    ge 0 : results available for orders up to & at    C
C                             position NL-IFAIL in the output arrays.  C
C                    = -3 : values at ZLMIN not found as over/underflowC
C                    = -4 : roundoff errors make results meaningless   C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     Machine dependent constants :                                    C
C                                                                      C
C     ACCU     target bound on relative error (except near 0 crossings)C
C               (ACCUR should be at least 100 * ACC8)                  C
C     ACC8    smallest number with 1+ACC8 .ne.1 in REAL*8  arithmetic  C
C     ACC16    smallest number with 1+ACC16.ne.1 in REAL*16 arithmetic C
C     FPMAX    magnitude of largest floating point number * ACC8       C
C     FPMIN    magnitude of smallest floating point number / ACC8      C
C                                                                      C
C     Parameters determining region of calculations :                  C
C                                                                      C
C        R20      estimate of (2F0 iterations)/(CF2 iterations)        C
C        ASYM     minimum X/(ETA**2+L) for CF1A to converge easily     C
C        XNEAR    minimum ABS(X) for CF2 to converge accurately        C
C        LIMIT    maximum no. iterations for CF1, CF2, and 1F1 series  C
C        JMAX     size of work arrays for Pade accelerations           C
C        NDROP    number of successive decrements to define instabilityC
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C     C309R1 = CF2,   C309R2 = F11,    C309R3 = F20,
C     C309R4 = CF1R,  C309R5 = CF1C,   C309R6 = CF1A,
C     C309R7 = RCF,   C309R8 = CTIDY.
C
      IMPLICIT COMPLEX*16 (A-H,O-Z)
C
      COMMON /COULC2/ NFP,N11,NPQ1,NPQ2,N20,KAS1,KAS2
      INTEGER NPQ(2),KAS(2)
      EQUIVALENCE (NPQ(1),NPQ1),(NPQ(2),NPQ2)
      EQUIVALENCE (KAS(1),KAS1),(KAS(2),KAS2)
      DOUBLE PRECISION ZERO,ONE,TWO,HALF
      DOUBLE PRECISION R20,ASYM,XNEAR
      DOUBLE PRECISION FPMAX,FPMIN,FPLMAX,FPLMIN
      DOUBLE PRECISION ACCU,ACC8,ACC16
      DOUBLE PRECISION HPI,TLOG
      DOUBLE PRECISION ERR,RERR,ABSC,ACCUR,ACCT,ACCH,ACCB,C309R4
      DOUBLE PRECISION PACCQ,EPS,OFF,SCALE,SF,SFSH,TA,RK,OMEGA,ABSX
      DOUBLE PRECISION DX1,DETA,DZLL

      LOGICAL LPR,ETANE0,IFCP,RLEL,DONEM,UNSTAB,ZLNEG,AXIAL,NOCF2,NPINT

      PARAMETER(ZERO = 0, ONE = 1, TWO = 2, HALF = ONE/TWO)
      PARAMETER(CI = (0,1), CIH = HALF*CI)
      PARAMETER(R20 = 3, ASYM = 3, XNEAR = HALF)
      PARAMETER(LIMIT = 20000, NDROP = 5, JMAX = 50)

      PARAMETER(FPMAX = 1D21, FPMIN = 3D-22)
      PARAMETER(ACCU = 5D-15, ACC8 = 2D-17, ACC16 = 3D-34)

      PARAMETER(HPI  = 1.57079 63267 94896 619D0)
      PARAMETER(TLOG = 0.69314 71805 59945 309D0)

      DIMENSION FC(0:*),GC(0:*),FCP(0:*),GCP(0:*),SIG(0:*)
      DIMENSION XRCF(JMAX,4)

      NINTC(W)=NINT(DREAL(W))
      ABSC(W)=ABS(DREAL(W))+ABS(DIMAG(W))
      NPINT(W,ACCB)=ABSC(NINTC(W)-W) .LT. ACCB .AND. DREAL(W) .LT. HALF
C
      MODE=MOD(ABS(MODE1),10)
      IFCP=MOD(MODE,2) .EQ. 1
      LPR=IPR .NE. 0
      IFAIL=-2
      N11=0
      NFP=0
      KAS(1)=0
      KAS(2)=0
      NPQ(1)=0
      NPQ(2)=0
      N20=0

      ACCUR=MAX(ACCU,50*ACC8)
      ACCT=HALF*ACCUR
      ACCH=SQRT(ACCUR)
      ACCB=SQRT(ACCH)
      RERR=ACCT
      FPLMAX=LOG(FPMAX)
      FPLMIN=LOG(FPMIN)
C
      CIK=ONE
      IF(KFN .GE. 3) CIK=CI*SIGN(ONE,FPMIN-DIMAG(ZZ))
      X=ZZ*CIK
      ETA=ETA1
      IF(KFN .GT. 0) ETA=ZERO
      ETANE0=ABSC(ETA) .GT. ACC8
      ETAI=ETA*CI
      DELL=ZERO
      IF(KFN .GE. 2) DELL=HALF
      ZM1=ZLMIN-DELL
      SCALE=ZERO
      IF(MODE1 .LT. 0) SCALE=DIMAG(X)
C
      M1=1
      L1=M1+NL
      RLEL=ABS(DIMAG(ETA))+ABS(DIMAG(ZM1)) .LT. ACC8
      ABSX=ABS(X)
      AXIAL=RLEL .AND. ABS(DIMAG(X)) .LT. ACC8*ABSX
      IF(MODE .LE. 2 .AND. ABSX .LT. FPMIN) GO TO 310
      XI=ONE/X
      XLOG=LOG(X)

C       log with cut along the negative real axis, see also OMEGA

      ID=1
      DONEM=.FALSE.
      UNSTAB=.FALSE.
      LF=M1
      IFAIL=-1
   10 ZLM=ZM1+(LF-M1)
      ZLL=ZM1+(L1-M1)
C
C ***       ZLL  is final lambda value, or 0.5 smaller for J,Y Bessels
C
      Z11=ZLL
      IF(ID .LT. 0) Z11=ZLM
      P11=CI*SIGN(ONE,ACC8-DIMAG(ETA))
      LAST=L1
C
C ***       Find phase shifts and Gamow factor at lambda = ZLL
C
      PK=ZLL+ONE
      AA=PK-ETAI
      AB=PK+ETAI
      BB=TWO*PK
      ZLNEG=NPINT(BB,ACCB)
      CLGAA=WLOGAM(AA)
      CLGAB=CLGAA
      IF(ETANE0 .AND. .NOT.RLEL) CLGAB=WLOGAM(AB)
      IF(ETANE0 .AND. RLEL) CLGAB=DCONJG(CLGAA)
      SIGMA=(CLGAA-CLGAB)*CIH
      IF(KFN .EQ. 0) SIG(L1)=SIGMA
      IF(.NOT.ZLNEG) CLL=ZLL*TLOG-HPI*ETA-WLOGAM(BB)+(CLGAA+CLGAB)*HALF
      THETA=X-ETA*(XLOG+TLOG)-ZLL*HPI+SIGMA
C
      TA=(DIMAG(AA)**2+DIMAG(AB)**2+ABS(DREAL(AA))+ABS(DREAL(AB)))*HALF
      IF(ID .GT. 0 .AND. ABSX .LT. TA*ASYM .AND. .NOT.ZLNEG) GO TO 20
C
C ***         use CF1 instead of CF1A, if predicted to converge faster,
C                 (otherwise using CF1A as it treats negative lambda &
C                  recurrence-unstable cases properly)
C
      RK=SIGN(ONE,DREAL(X)+ACC8)
      P=THETA
      IF(RK .LT. 0) P=-X+ETA*(LOG(-X)+TLOG)-ZLL*HPI-SIGMA
      XRCF(1,1)=PK
      F=RK*C309R6(X*RK,ETA*RK,ZLL,P,ACCT,JMAX,NFP,FEST,ERR,FPMAX,XRCF,
     1                                      XRCF(1,3),XRCF(1,4))
      FESL=LOG(FEST)+ABS(DIMAG(X))
      NFP=-NFP
      IF(NFP .LT. 0 .OR. UNSTAB .AND. ERR .LT. ACCB) GO TO 40
      IF(.NOT.ZLNEG .OR. UNSTAB .AND. ERR .GT. ACCB) GO TO 20
      IF(LPR) WRITE(6,1060) '-L',ERR
      IF(ERR.GT.ACCB) GO TO 280
      GO TO 40
C
C ***    evaluate CF1  =  f   =  F'(ZLL,ETA,X)/F(ZLL,ETA,X)
C
   20 IF(AXIAL) THEN
       DX1=X
       DETA=ETA
       DZLL=ZLL
       F=C309R4(DX1,DETA,DZLL,ACC8,SF,RK,ETANE0,LIMIT,ERR,NFP,
     1          FPMIN,FPMAX,LPR)
       FCL=SF
       TPK1=RK
      ELSE
       F=C309R5(X,ETA,ZLL,ACC8,FCL,TPK1,ETANE0,LIMIT,ERR,NFP,
     1          FPMIN,FPMAX,LPR)
      END IF
      IF(ERR .GT. ONE) THEN
       IFAIL=-1
       GO TO 290
      END IF
C
C ***  Make a simple check for CF1 being badly unstable:
C
      IF(ID .GE. 0) THEN
       UNSTAB=DREAL((ONE-ETA*XI)*CI*DIMAG(THETA)/F) .GT. ZERO
     1  .AND. .NOT.AXIAL .AND. ABS(DIMAG(THETA)) .GT. -LOG(ACC8)*HALF
     2  .AND. ABSC(ETA)+ABSC(ZLL) .LT. ABSC(X)
       IF(UNSTAB) THEN
        ID=-1
        LF=L1
        L1=M1
        RERR=ACCT
        GO TO 10
       END IF
      END IF
C
C *** compare accumulated phase FCL with asymptotic phase for G(k+1) :
C     to determine estimate of F(ZLL) (with correct sign) to start recur
C
      W=X*X*(HALF/TPK1+ONE/TPK1**2)+ETA*(ETA-TWO*X)/TPK1
      FESL=(ZLL+ONE)*XLOG+CLL-W-LOG(FCL)
   40 FESL=FESL-ABS(SCALE)
      RK=MAX(DREAL(FESL),FPLMIN*HALF)
      FESL=DCMPLX(MIN(RK,FPLMAX*HALF),DIMAG(FESL))
      FEST=EXP(FESL)
C
      RERR=MAX(RERR,ERR,ACC8*ABS(DREAL(THETA)))
C
      FCL=FEST
      FPL=FCL*F
      IF(IFCP) FCP(L1)=FPL
      FC(L1)=FCL
C
C *** downward recurrence to lambda = ZLM. array GC,if present,stores RL
C
      I=MAX(-ID,0)
      ZL=ZLL+I
      MONO=0
      OFF=ABS(FCL)
      TA=ABSC(SIGMA)

C
C     CORRESPONDS TO   DO 70 L = L1-ID,LF,-ID
C
      L=L1-ID
      LC70=(L1-LF)/ID
   70 IF(LC70 .LE. 0) GO TO 80
      IF(ETANE0) THEN
       IF(RLEL) THEN
        DSIG=ATAN2(DREAL(ETA),DREAL(ZL))
        RL=SQRT(DREAL(ZL)**2+DREAL(ETA)**2)
       ELSE
        AA=ZL-ETAI
        BB=ZL+ETAI
        IF(ABSC(AA) .LT. ACCH .OR. ABSC(BB) .LT. ACCH) GOTO 50
        DSIG=(LOG(AA)-LOG(BB))*CIH
        RL=AA*EXP(CI*DSIG)
       END IF
       IF(ABSC(SIGMA) .LT. TA*HALF) THEN

C               re-calculate SIGMA because of accumulating roundoffs:

        SL=(WLOGAM(ZL+I-ETAI)-WLOGAM(ZL+I+ETAI))*CIH
        RL=(ZL-ETAI)*EXP(CI*ID*(SIGMA-SL))
        SIGMA=SL
        TA=ZERO
       ELSE
        SIGMA=SIGMA-DSIG*ID
       END IF
       TA=MAX(TA,ABSC(SIGMA))
       SL=ETA+ZL*ZL*XI
       PL=ZERO
       IF(ABSC(ZL) .GT. ACCH) PL=(SL*SL-RL*RL)/ZL
       FCL1=(FCL*SL+ID*ZL*FPL)/RL
       SF=ABS(FCL1)
       IF(SF .GT. FPMAX) GO TO 350
       FPL=(FPL*SL+ID*PL*FCL)/RL
       IF(MODE .LE. 1) GCP(L+ID)=PL*ID
      ELSE

C                      ETA = 0, including Bessels.  NB RL==SL

       RL=ZL*XI
       FCL1=FCL*RL+FPL*ID
       SF=ABS(FCL1)
       IF(SF .GT. FPMAX) GO TO 350
       FPL=(FCL1*RL-FCL)*ID
      END IF
      MONO=MONO+1
      IF(SF .GE. OFF) MONO=0
      FCL=FCL1
      OFF=SF
      FC(L)=FCL
      IF(IFCP) FCP(L)=FPL
      IF(KFN .EQ. 0) SIG(L)=SIGMA
      IF(MODE .LE. 2) GC(L+ID)=RL
      ZL=ZL-ID
      IF(MONO .LT. NDROP .OR. AXIAL .OR.
     1             DREAL(ZLM)*ID .GT. -NDROP .AND. .NOT.ETANE0) THEN
       L=L-ID
       LC70=LC70-1
       GO TO 70
      END IF
      UNSTAB=.TRUE.
C
C ***    take action if cannot or should not recur below this ZL:

   50 ZLM=ZL
      LF=L
      IF(ID .LT. 0) GO TO 380
      IF(.NOT.UNSTAB) LF=L+1
      IF(L+MONO .LT. L1-2 .OR. ID .LT. 0 .OR. .NOT.UNSTAB) GO TO 80

C             otherwise, all L values (for stability) should be done
C                        in the reverse direction:

      ID=-1
      LF=L1
      L1=M1
      RERR=ACCT
      GO TO 10

   80 IF(FCL .EQ. ZERO) FCL=ACC8
      F=FPL/FCL
C
C *** Check, if second time around, that the 'f' values agree!
C
      IF(ID .GT. 0) FIRST=F
      IF(DONEM) RERR=MAX(RERR,ABSC(F-FIRST)/ABSC(F))
      IF(DONEM) GO TO 90
C
      NOCF2=.FALSE.
      THETAM=X-ETA*(XLOG+TLOG)-ZLM*HPI+SIGMA
C
C *** on left x-plane, determine OMEGA by requiring cut on -x axis
C     on right x-plane, choose OMEGA (using estimate based on THETAM)
C       so H(omega) is smaller and recurs upwards accurately.
C     (x-plane boundary is shifted to give CF2(LH) a chance to converge)
C
      OMEGA=SIGN(ONE,DIMAG(X)+ACC8)
      IF(DREAL(X) .GE. XNEAR) OMEGA=SIGN(ONE,DIMAG(THETAM)+ACC8)
      SFSH=EXP(OMEGA*SCALE-ABS(SCALE))
      OFF=EXP(MIN(TWO*MAX(ABS(DIMAG(X)),ABS(DIMAG(THETAM)),
     1                         ABS(DIMAG(ZLM))*3),FPLMAX))
      EPS=MAX(ACC8,ACCT*HALF/OFF)
C
C ***    Try first estimated omega, then its opposite,
C        to find the H(omega) linearly independent of F
C        i.e. maximise  CF1-CF2 = 1/(F H(omega)) , to minimise H(omega)
C
   90 DO 100 L = 1,2
      LH=1
      IF(OMEGA .LT. ZERO) LH=2
      PM=CI*OMEGA
      ETAP=ETA*PM
      IF(DONEM) GO TO 130
      PQ1=ZERO
      PACCQ=ONE
      KASE=0
C
C ***            Check for small X, i.e. whether to avoid CF2 :
C
      IF(MODE .GE. 3 .AND. ABSX .LT. ONE ) GO TO 190
      IF(MODE .LT. 3 .AND. (NOCF2 .OR. ABSX .LT. XNEAR .AND.
     1   ABSC(ETA)*ABSX .LT. 5 .AND. ABSC(ZLM) .LT. 4)) THEN
       KASE=5
       GO TO 120
      END IF
C
C ***  Evaluate   CF2 : PQ1 = p + i.omega.q  at lambda = ZLM
C
      PQ1=C309R1(X,ETA,ZLM,PM,EPS,LIMIT,ERR,NPQ(LH),ACC8,ACCH,
     1             LPR,ACCUR,DELL)
      ERR=ERR*MAX(ONE,ABSC(PQ1)/MAX(ABSC(F-PQ1),ACC8))
C
C *** check if impossible to get F-PQ accurately because of cancellation
C                original guess for OMEGA (based on THETAM) was wrong
C                Use KASE 5 or 6 if necessary if Re(X) < XNEAR
      IF(ERR .LT. ACCH) GO TO 110
      NOCF2=DREAL(X) .LT. XNEAR .AND. ABS(DIMAG(X)) .LT. -LOG(ACC8)
  100 OMEGA=-OMEGA
      IF(UNSTAB) GO TO 360
      IF(LPR .AND. DREAL(X) .LT. -XNEAR) WRITE(6,1060) '-X',ERR
  110 RERR=MAX(RERR,ERR)
C
C ***  establish case of calculation required for irregular solution
C
  120 IF(KASE .GE. 5) GO TO 130
      IF(DREAL(X) .GT. XNEAR) THEN

C          estimate errors if KASE 2 or 3 were to be used:

       PACCQ=EPS*OFF*ABSC(PQ1)/MAX(ABS(DIMAG(PQ1)),ACC8)
      END IF
      IF(PACCQ .LT. ACCUR) THEN
       KASE=2
       IF(AXIAL) KASE=3
      ELSE
       KASE=1
       IF(NPQ(1)*R20 .LT. JMAX) KASE=4
C             i.e. change to kase=4 if the 2F0 predicted to converge
      END IF
  130 GO TO (190,140,150,170,190,190), ABS(KASE)
  140 IF(.NOT.DONEM)
C
C ***  Evaluate   CF2 : PQ2 = p - i.omega.q  at lambda = ZLM   (Kase 2)
C
     1  PQ2=C309R1(X,ETA,ZLM,-PM,EPS,LIMIT,ERR,NPQ(3-LH),ACC8,ACCH,
     2             LPR,ACCUR,DELL)
      P=(PQ2+PQ1)*HALF
      Q=(PQ2-PQ1)*HALF*PM
      GO TO 160
  150 P=DREAL(PQ1)
      Q=DIMAG(PQ1)
C
C ***   With Kase = 3 on the real axes, P and Q are real & PQ2 = PQ1*
C
      PQ2=DCONJG(PQ1)
C
C *** solve for FCM = F at lambda = ZLM,then find norm factor W=FCM/FCL
C
  160 W=(PQ1-F)*(PQ2-F)
      SF=EXP(-ABS(SCALE))
      FCM=SQRT(Q/W)*SF

C                  any SQRT given here is corrected by
C                  using sign for FCM nearest to phase of FCL

      IF(DREAL(FCM/FCL) .LT. ZERO) FCM=-FCM
      GAM=(F-P)/Q
      TA=ABSC(GAM+PM)
      PACCQ=EPS*MAX(TA,ONE/TA)
      HCL=FCM*(GAM+PM)*(SFSH/(SF*SF))

C                            Consider a KASE = 1 Calculation

      IF(PACCQ .GT. ACCUR .AND. KASE .GT. 0) THEN
       F11V=C309R2(X,ETA,Z11,P11,ACCT,LIMIT,0,ERR,N11,FPMAX,ACC8,ACC16)
       IF(ERR .LT. PACCQ) GO TO 200
      END IF
      RERR=MAX(RERR,PACCQ)
      GO TO 230
C
C *** Arrive here if KASE = 4
C     to evaluate the exponentially decreasing H(LH) directly.
C
  170 IF(DONEM) GO TO 180
      AA=ETAP-ZLM
      BB=ETAP+ZLM+ONE
      F20V=C309R3(AA,BB,-HALF*PM*XI,ACCT,JMAX,ERR,FPMAX,N20,XRCF)
      IF(N20 .LE. 0) GO TO 190
      RERR=MAX(RERR,ERR)
      HCL=FPMIN
      IF(ABS(DREAL(PM*THETAM)+OMEGA*SCALE) .GT. FPLMAX) GO TO 330
  180 HCL=F20V*EXP(PM*THETAM+OMEGA*SCALE)
      FCM=SFSH/((F-PQ1)*HCL)
      GO TO 230
C
C *** Arrive here if KASE=1   (or if 2F0 tried mistakenly & failed)
C
C           for small values of X, calculate F(X,SL) directly from 1F1
C               using DREAL*16 arithmetic if possible.
C           where Z11 = ZLL if ID>0, or = ZLM if ID<0
C
  190 F11V=C309R2(X,ETA,Z11,P11,ACCT,LIMIT,0,ERR,N11,FPMAX,ACC8,ACC16)
  200 IF(N11 .LT. 0) THEN

C                               F11 failed from BB = negative integer

       IF(LPR) WRITE(6,1060) '-L',ONE
       IFAIL=-1
       GO TO 290
      END IF

C                      Consider a KASE 2 or 3 calculation :

      IF(ERR .GT. PACCQ .AND. PACCQ .LT. ACCB) THEN
       KASE=-2
       IF(AXIAL) KASE=-3
       GO TO 130
      END IF
      RERR=MAX(RERR,ERR)
      IF(ERR .GT. FPMAX) GO TO 370
      IF(ID .LT. 0) CLL=Z11*TLOG-HPI*ETA-WLOGAM(BB)
     1                        +WLOGAM(Z11+ONE+P11*ETA)-P11*SIGMA
      EK=(Z11+ONE)*XLOG-P11*X+CLL-ABS(SCALE)
      IF(ID .GT. 0) EK=EK-FESL+LOG(FCL)
      IF(DREAL(EK) .GT. FPLMAX) GO TO 350
      IF(DREAL(EK) .LT. FPLMIN) GO TO 340
      FCM=F11V*EXP(EK)
      IF(KASE .GE. 5) THEN
       IF(ABSC(ZLM+ZLM-NINTC(ZLM+ZLM)) .LT. ACCH) KASE=6
C
C ***  For abs(X) < XNEAR, then CF2 may not converge accurately, so
C ***      use an expansion for irregular soln from origin :
C
       SL=ZLM
       ZLNEG=DREAL(ZLM) .LT. -ONE+ACCB
       IF(KASE .EQ. 5 .OR. ZLNEG) SL=-ZLM-ONE
       PK=SL+ONE
       AA=PK-ETAP
       AB=PK+ETAP
       BB=TWO*PK
       CLGAA=WLOGAM(AA)
       CLGAB=CLGAA
       IF(ETANE0) CLGAB=WLOGAM(AB)
       CLGBB=WLOGAM(BB)
       IF(KASE .EQ. 6 .AND. .NOT.ZLNEG) THEN
        IF(NPINT(AA,ACCUR)) CLGAA=CLGAB-TWO*PM*SIGMA
        IF(NPINT(AB,ACCUR)) CLGAB=CLGAA+TWO*PM*SIGMA
       END IF
       CLL=SL*TLOG-HPI*ETA-CLGBB+(CLGAA+CLGAB)*HALF
       DSIG=(CLGAA-CLGAB)*PM*HALF
       IF(KASE .EQ. 6) P11=-PM
       EK=PK*XLOG-P11*X+CLL-ABS(SCALE)
       SF=EXP(-ABS(SCALE))
       CHI=ZERO
       IF(.NOT.(KASE .EQ. 5 .OR. ZLNEG)) GO TO 210
C
C ***  Use  G(l)  =  (cos(CHI) * F(l) - F(-l-1)) /  sin(CHI)
C
C      where CHI = sig(l) - sig(-l-1) - (2l+1)*pi/2
C
       CHI=SIGMA-DSIG-(ZLM-SL)*HPI
       F11V=C309R2(X,ETA,SL,P11,ACCT,LIMIT,0,ERR,NPQ(1),
     1             FPMAX,ACC8,ACC16)
       RERR=MAX(RERR,ERR)
       IF(KASE .EQ. 6) GO TO 210
       FESL=F11V*EXP(EK)
       FCL1=EXP(PM*CHI)*FCM
       HCL=FCL1-FESL
       RERR=MAX(RERR,ACCT*MAX(ABSC(FCL1),ABSC(FESL))/ABSC(HCL))
       HCL=HCL/SIN(CHI)*(SFSH/(SF*SF))
       GO TO 220
C
C *** Use the logarithmic expansion for the irregular solution (KASE 6)
C        for the case that BB is integral so sin(CHI) would be zero.
C
  210  RL=BB-ONE
       N=NINTC(RL)
       ZLOG=XLOG+TLOG-PM*HPI
       CHI=CHI+PM*THETAM+OMEGA*SCALE+AB*ZLOG
       AA=ONE-AA
       IF(NPINT(AA,ACCUR)) THEN
        HCL=ZERO
       ELSE
        IF(ID .GT. 0 .AND. .NOT.ZLNEG) F11V=FCM*EXP(-EK)
        HCL=EXP(CHI-CLGBB-WLOGAM(AA))*(-1)**(N+1)*(F11V*ZLOG+
     1   C309R2(X,ETA,SL,-PM,ACCT,LIMIT,2,ERR,NPQ(2),FPMAX,ACC8,ACC16))
        RERR=MAX(RERR,ERR)
       END IF
       IF(N .GT. 0) THEN
        EK=CHI+WLOGAM(RL)-CLGAB-RL*ZLOG
        DF=C309R2(X,ETA,-SL-ONE,-PM,ZERO,N,0,ERR,L,FPMAX,ACC8,ACC16)
        HCL=HCL+EXP(EK)*DF
       END IF
       RERR=MAX(RERR,TWO*ABS(BB-NINTC(BB)))
  220  PQ1=F-SFSH/(FCM*HCL)
      ELSE
       IF(MODE .LE. 2) HCL=SFSH/((F-PQ1)*FCM)
       KASE=1
      END IF
C
C ***  Now have absolute normalisations for Coulomb Functions
C          FCM & HCL  at lambda = ZLM
C      so determine linear transformations for Functions required :
C
  230 IH=ABS(MODE1)/10
      IF(KFN .EQ. 3) IH=(3-DIMAG(CIK))/2+HALF
      P11=ONE
      IF(IH .EQ. 1) P11=CI
      IF(IH .EQ. 2) P11=-CI
      DF=-PM
      IF(IH .GE. 1) DF=-PM+P11
      IF(ABSC(DF) .LT. ACCH) DF=ZERO
C
C *** Normalisations for spherical or cylindrical Bessel functions
C
      IF(KFN .LE. 0) THEN
       ALFA=ZERO
       BETA=ONE
      ELSE IF(KFN .EQ. 1) THEN
       ALFA=XI
       BETA=XI
      ELSE
       ALFA=XI*HALF
       BETA=SQRT(XI/HPI)
       IF(DREAL(BETA) .LT. ZERO) BETA=-BETA
      END IF
      AA=ONE
      IF(KFN .GT. 0) AA=-P11*BETA

C                Calculate rescaling factors for I & K output

      IF(KFN .GE. 3) THEN
       P=EXP((ZLM+DELL)*HPI*CIK)
       AA=BETA*HPI*P
       BETA=BETA/P
       Q=CIK*ID
      END IF

C                  Calculate rescaling factors for GC output

      IF(IH .EQ. 0) THEN
       TA=ABS(SCALE)+DIMAG(PM)*SCALE
       RK=ZERO
       IF(TA .LT. FPLMAX) RK=EXP(-TA)
      ELSE
       TA=ABS(SCALE)+DIMAG(P11)*SCALE
       IF(ABSC(DF) .GT. ACCH .AND. TA .GT. FPLMAX) GO TO 320
       IF(ABSC(DF) .GT. ACCH) DF=DF*EXP(TA)
       SF=TWO*(LH-IH)*SCALE
       RK=ZERO
       IF(SF .GT. FPLMAX) GO TO 320
       IF(SF .GT. FPLMIN) RK=EXP(SF)
      END IF
      KAS((3-ID)/2)=KASE
      W=FCM/FCL
      IF(LOG(ABSC(W))+LOG(ABSC(FC(LF))) .LT. FPLMIN) GO TO 340
      IF(MODE .GE. 3) GO TO 240
      IF(LPR .AND. ABSC(F-PQ1) .LT. ACCH*ABSC(F))
     1                             WRITE(6,1020) LH,ZLM+DELL
      HPL=HCL*PQ1
      IF(ABSC(HPL) .LT. FPMIN .OR. ABSC(HCL) .LT. FPMIN) GO TO 330
C
C *** IDward recurrence from HCL,HPL(LF) (stored GC(L) is RL if reqd)
C *** renormalise FC,FCP at each lambda
C ***    ZL   = ZLM - MIN(ID,0) here
C
  240 DO 270 L = LF,L1,ID
      FCL=W*FC(L)
      IF(ABSC(FCL) .LT. FPMIN) GO TO 340
      IF(IFCP) FPL=W*FCP(L)
      FC(L)=BETA*FCL
      IF(IFCP) FCP(L)=BETA*(FPL-ALFA*FCL)*CIK
      FC(L)=C309R8(FC(L),ACCUR)
      IF(IFCP) FCP(L)=C309R8(FCP(L),ACCUR)
      IF(MODE .GE. 3) GO TO 260
      IF(L .EQ. LF) GO TO 250
      ZL=ZL+ID
      ZID=ZL*ID
      RL=GC(L)
      IF(ETANE0) THEN
       SL=ETA+ZL*ZL*XI
       IF(MODE .EQ. 1) THEN
        PL=GCP(L)
       ELSE
        PL=ZERO
        IF(ABSC(ZL) .GT. ACCH) PL=(SL*SL-RL*RL)/ZID
       END IF
       HCL1=(SL*HCL-ZID*HPL)/RL
       HPL=(SL*HPL-PL*HCL)/RL
      ELSE
       HCL1=RL*HCL-HPL*ID
       HPL=(HCL-RL*HCL1)*ID
      END IF
      HCL=HCL1
      IF(ABSC(HCL) .GT. FPMAX) GO TO 320
  250 GC(L)=AA*(RK*HCL+DF*FCL)
      IF(MODE .EQ. 1) GCP(L)=(AA*(RK*HPL+DF*FPL)-ALFA*GC(L))*CIK
      GC(L)=C309R8(GC(L),ACCUR)
      IF(MODE .EQ. 1) GCP(L)=C309R8(GCP(L),ACCUR)
      IF(KFN .GE. 3) AA=AA*Q
  260 IF(KFN .GE. 3) BETA=-BETA*Q
  270 LAST=MIN(LAST,(L1-L)*ID)
      GO TO 280
C
C *** Come here after all soft errors to determine how many L values ok
C
  310 IF(LPR) WRITE(6,1000) ZZ
      GO TO 999
  320 IF(LPR) WRITE(6,1010) ZL+DELL,'IR',HCL,'>',FPMAX
      GO TO 280
  330 IF(LPR) WRITE(6,1010) ZL+DELL,'IR',HCL,'<',FPMIN
      GO TO 280
  340 IF(LPR) WRITE(6,1010) ZL+DELL,'  ',FCL,'<',FPMIN
      GO TO 280
  350 IF(LPR) WRITE(6,1010) ZL+DELL,'  ',FCL,'>',FPMAX
      GO TO 280
  360 IF(LPR) WRITE(6,1030) ZL+DELL
      GO TO 280
  370 IF(LPR) WRITE(6,1040) Z11,I
      IFAIL=-1
      GO TO 290
  380 IF(LPR) WRITE(6,1050) ZLMIN,ZLM,ZLM+ONE,ZLMIN+NL
      IFAIL=-1
      GO TO 290
  280 IF(ID .GT. 0 .OR. LAST .EQ. 0) IFAIL=LAST
      IF(ID .LT. 0 .AND. LAST .NE. 0) IFAIL=-3
C
C *** Come here after ALL errors for this L range (ZLM,ZLL)
C
C *** so on first block, 'F' started decreasing monotonically,
C                        or hit bound states for low ZL.
C     thus redo M1 to LF-1 in reverse direction, i.e. do
C      CF1A at ZLMIN & CF2 at ZLM (midway between ZLMIN & ZLMAX)
C
  290 IF(ID .GT. 0 .AND. LF .NE. M1) THEN
       ID=-1
       IF(.NOT.UNSTAB) LF=LF-1
       DONEM=UNSTAB
       LF=MIN(LF,L1)
       L1=M1
       GO TO 10
      END IF
      IF(IFAIL .LT. 0) GO TO 999
      IF(LPR .AND. RERR .GT. ACCB) WRITE(6,1070) RERR
      IF(RERR .GT. 0.1D0) IFAIL=-4
  999 DO 998 L = 1,NL+1
      FC(L-1)=FC(L)
      GC(L-1)=GC(L)
      FCP(L-1)=FCP(L)
      GCP(L-1)=GCP(L)
  998 SIG(L-1)=SIG(L)
      RETURN
C
 1000 FORMAT(1X,'***** CERN C309 WCLBES ... ',
     1 'CANNOT CALCULATE IRREGULAR SOLUTIONS FOR X =',
     2 1P,2D10.2,' ABS(X) TOO SMALL')
 1010 FORMAT(1X,'***** CERN C309 WCLBES ... ',
     1 'AT ZL =',2F8.3,' ',A2,'REGULAR SOLUTION (',1P,2E10.1,') ',
     2 A1,E10.1)
 1020 FORMAT(1X,'***** CERN C309 WCLBES ... ',
     1 'WARNING: LINEAR INDEPENDENCE BETWEEN ''F'' AND ''H(',I1,
     2 ')'' IS LOST AT ZL = ',2F7.2/1X,'*****',22X,'(EG. COULOMB ',
     3 'EIGENSTATE OR CF1 UNSTABLE)')
 1030 FORMAT(1X,'***** CERN C309 WCLBES ... ',
     2 '(ETA & L)/X TOO LARGE FOR CF1A, AND CF1 UNSTABLE AT L = ',2F8.2)
 1040 FORMAT(1X,'***** CERN C309 WCLBES ... ',
     1 'OVERFLOW IN 1F1 SERIES AT ZL = ',2F8.3,' AT TERM',I5)
 1050 FORMAT(1X,'***** CERN C309 WCLBES ... ',
     1 'BOTH BOUND-STATE POLES AND F-INSTABILITIES OCCUR OR MULTIPLE',
     2 ' INSTABILITIES PRESENT'/
     3   1X,'*****',22X,'TRY CALLING TWICE, 1ST FOR ZL FROM',2F8.3,
     4 ' TO',2F8.3,' (INCL)'/1X,'*****',41X,'2ND FOR ZL FROM',2F8.3,
     5 ' TO',2F8.3)
 1060 FORMAT(1X,'***** CERN C309 WCLBES ... ',
     1 'WARNING: AS ''',A2,''' REFLECTION RULES NOT USED ',
     2 'ERRORS CAN BE UP TO',1PD12.2)
 1070 FORMAT(1X,'***** CERN C309 WCLBES ... ',
     1 'WARNING: OVERALL ROUNDOFF ERROR APPROXIMATELY',1PE11.1)
      END
CDECK  ID>, R1DP.   
      FUNCTION C309R1(X,ETA,ZL,PM,EPS,LIMIT,ERR,NPQ,ACC8,ACCH,
     1             LPR,ACCUR,DELL)
C
C                                    (omega)        (omega)
C *** Evaluate  CF2  = p + PM.q  =  H   (ETA,X)' / H   (ETA,X)
C                                    ZL             ZL
C     where PM = omega.i
C
      IMPLICIT COMPLEX*16(A-H,O-Z)
      LOGICAL LPR
      DOUBLE PRECISION EPS,ERR,ACC8,ACCH,ACCUR,TA,RK
      DOUBLE PRECISION ABSC,HALF

      PARAMETER(HALF = 1D0/2D0)

      ABSC(W)=ABS(DREAL(W))+ABS(DIMAG(W))

      TA=LIMIT+LIMIT
      ETAP=ETA*PM
      XI=1/X
      WI=ETAP+ETAP
      RK=0
      PQ=(1-ETA*XI)*PM
      AA=-(ETA*ETA+ZL*ZL+ZL)+ETAP
      BB=2*(X-ETA+PM)
      RL=XI*PM
      IF(ABSC(BB) .LT. ACCH) THEN
       RL=RL*AA/(AA+RK+WI)
       PQ=PQ+RL*(BB+PM+PM)
       AA=AA+2*(RK+1+WI)
       BB=BB+4*PM
       RK=RK+4
      END IF
      DD=1/BB
      DL=AA*DD*RL
   10 PQ=PQ+DL
      RK=RK+2
      AA=AA+RK+WI
      BB=BB+PM+PM
      DD=1/(AA*DD+BB)
      DL=DL*(BB*DD-1)
      ERR=ABSC(DL)/ABSC(PQ)
      IF(ERR .GE. MAX(EPS,ACC8*RK*HALF) .AND. RK .LE. TA) GO TO 10
C
      NPQ=HALF*RK
      C309R1=PQ+DL
      IF(LPR .AND. NPQ .GE. LIMIT-1 .AND. ERR .GT. ACCUR)
     1 WRITE(6,1000) INT(DIMAG(PM)),NPQ,ERR,ZL+DELL
      RETURN
 1000 FORMAT(1X,'***** CERN C309 WCLBES ... ',
     2 'CF2(',I2,') NOT CONVERGED FULLY IN ',I7,' ITERATIONS'/1X,27X,
     3 'ERROR IN IRREGULAR SOLUTION =',1P,D11.2,' AT ZL = ',2F8.3)
      END
CDECK  ID>, R2DP.   
      FUNCTION C309R2(X,ETA,ZL,P,EPS,LIMIT,KIND,ERR,NITS,
     1                FPMAX,ACC8,ACC16)
C
C *** evaluate the HYPERGEOMETRIC FUNCTION
C                                        i
C            F (AA;BB; Z) = SUM  (AA)   Z / ( (BB)  i! )
C           1 1              i       i            i
C
C     to accuracy EPS with at most LIMIT terms.
C  If KIND = 0 : using extended precision but real arithmetic only,
C            1 : using normal precision in complex arithmetic,
C   or       2 : using normal complex arithmetic, but with WDIGAM factor
C
C  where AA, BB, and Z are defined below
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      COMPLEX*16 X,ETA,ZL,P,AA,BB,Z,C309R2,WDIGAM
      COMPLEX*16 DD,G,F,AI,BI,T
      DOUBLE PRECISION AR,BR,GR,GI,DR,DI,TR,TI,UR,UI,FI,FI1,DEN

      PARAMETER(TBBB = 3D0/2D0)


      ABSC(AA)=ABS(DREAL(AA))+ABS(DIMAG(AA))
      NINTC(AA)=NINT(DREAL(AA))

      C309R2 = 0.

      AA=ZL+1-ETA*P
      BB=2*ZL+2
      Z=2*P*X
      IF(DREAL(BB) .LE. 0 .AND. ABS(BB-NINTC(BB)) .LT.
     1 SQRT(SQRT(ACC8))**3 .AND. DREAL(BB)+LIMIT .GE. TBBB) THEN
       NITS=-1
       RETURN
      END IF
      IF(LIMIT .LE. 0) THEN
       C309R2=0
       ERR=0
       NITS=1
       RETURN
      END IF
      TA=1
      RK=1
      IF(KIND .LE. 0 .AND. ABSC(Z)*ABSC(AA) .GT. ABSC(BB)*1.0) THEN
       DR=1
       DI=0
       GR=1
       GI=0
       AR=DREAL(AA)
       BR=DREAL(BB)
       FI=0
       DO 20 I = 2,LIMIT
       FI1=FI+1
       TR=BR*FI1
       TI=DIMAG(BB)*FI1
       DEN=1/(TR*TR+TI*TI)
       UR=(AR*TR+DIMAG(AA)*TI)*DEN
       UI=(DIMAG(AA)*TR-AR*TI)*DEN
       TR=UR*GR-UI*GI
       TI=UR*GI+UI*GR
       GR=DREAL(Z)*TR-DIMAG(Z)*TI
       GI=DREAL(Z)*TI+DIMAG(Z)*TR
       DR=DR+GR
       DI=DI+GI
       ERR=ABS(GR)+ABS(GI)
       IF(ERR .GT. FPMAX) GO TO 60
       RK=ABS(DR)+ABS(DI)
       TA=MAX(TA,RK)
       IF(ERR .LT. RK*EPS .OR. I .GE. 4 .AND. ERR .LT. ACC16) GO TO 30
       FI=FI1
       AR=AR+1
   20  BR=BR+1
C
   30  C309R2=DR+(0,1)*DI
       ERR=ACC16*TA/RK
      ELSE
C
C*    If REAL*16 arithmetic is not available, (or already using it!),
C*    then use KIND > 0
C
       G=1
       F=1
       IF(KIND .GE. 2) F=WDIGAM(AA)-WDIGAM(BB)-WDIGAM(G)
       DD=F
       DO 40 I = 2,LIMIT
       AI=AA+(I-2)
       BI=BB+(I-2)
       R=I-1
       G=G*Z*AI/(BI*R)
C
C                       multiply by (psi(a+r)-psi(b+r)-psi(1+r))
C
       IF(KIND .EQ. 2) F=F+1/AI-1/BI-1/R
       T=G*F
       DD=DD+T
       ERR=ABSC(T)
       IF(ERR .GT. FPMAX) GO TO 60
       RK=ABSC(DD)
       TA=MAX(TA,RK)
       IF(ERR .LT. RK*EPS .OR. ERR .LT. ACC8 .AND. I .GE. 4) GO TO 50
   40  CONTINUE

   50  ERR=ACC8*TA/RK
       C309R2=DD
      END IF
   60 NITS=I
      RETURN
      END
CDECK  ID>, R3DP.   
      FUNCTION C309R3(AA,BB,Z,EPS,JMAX,RE,FPMAX,N,X)
C
C     evaluate the HYPERGEOMETRIC FUNCTION
C                                             i
C            F (AA,BB;;Z) = SUM  (AA)  (BB)  Z / i!
C           2 0              i       i     i
C
C     to accuracy EPS with at most JMAX terms.
C
C     if the terms start diverging,
C     the corresponding continued fraction is found by RCF
C     & evaluated progressively by Steed's method to obtain convergence.
C
      IMPLICIT COMPLEX*16(A-H,O-Z)
      DIMENSION X(JMAX,4)
      LOGICAL FINITE
      DOUBLE PRECISION EP,EPS,AT,ATL,ABSC,RE,FPMAX

      ABSC(W)=ABS(DREAL(W))+ABS(DIMAG(W))
      NINTC(W)=NINT(DREAL(W))
C
      RE=0
      X(1,1)=1
      SUM=X(1,1)
      ATL=ABSC(X(1,1))
      F=SUM
      D=1
      DF=SUM
      J=0
      EP=EPS*(10*JMAX)
      MA=-NINTC(AA)
      MB=-NINTC(BB)
      FINITE=ABS(ABS(DREAL(AA))-MA) .LT. EP .AND. ABS(DIMAG(AA)) .LT. EP
     1  .OR. ABS(ABS(DREAL(BB))-MB) .LT. EP .AND. ABS(DIMAG(BB)) .LT. EP
      IMAX=JMAX
      IF(FINITE .AND. MA .GE. 0) IMAX=MIN(MA+1,IMAX)
      IF(FINITE .AND. MB .GE. 0) IMAX=MIN(MB+1,IMAX)
      DO 10 I = 2,IMAX
      X(I,1)=X(I-1,1)*Z*(AA+I-2)*(BB+I-2)/(I-1)
      IF(ABSC(X(I,1)) .GT. FPMAX) THEN
       N=0
       C309R3=SUM
       IF(.NOT.FINITE) RE=AT/ABSC(SUM)
       RETURN
      END IF
      AT=ABSC(X(I,1))
      IF(J .EQ. 0) THEN
       SUM=SUM+X(I,1)
       IF(AT .LT. ABSC(SUM)*EPS) THEN
        N=I
        C309R3=SUM
        IF(.NOT.FINITE) RE=AT/ABSC(SUM)
        RETURN
       END IF
      END IF
      IF(FINITE) GO TO 10
      IF(J .GT. 0 .OR. AT .GT. ATL .OR. I .GE. JMAX-2) J=J+1
      IF(J .EQ. 0) GO TO 10
      CALL C309R7(X(1,1),X(1,2),J,I,X(1,3),EPS)
      IF(I .LT. 0) THEN
       N=0
       C309R3=SUM
       IF(.NOT.FINITE) RE=AT/ABSC(SUM)
       RETURN
      END IF
      DO 50 K = MAX(J,2),I
      D=1/(D*X(K,2)+1)
      DF=DF*D-DF
      F=F+DF
      IF(ABSC(DF) .LT. ABSC(F)*EPS .OR.
     1   DF .EQ. 0 .AND. F .EQ. 0 .AND. I .GE. 4) THEN
       N=K
       C309R3=F
       RE=ABSC(DF)/ABSC(F)
       RETURN
      END IF
   50 CONTINUE
      J=I
   10 ATL=AT
      IF(.NOT.FINITE) I=-JMAX
      N=I
      C309R3=SUM
      IF(.NOT.FINITE) RE=AT/ABSC(SUM)
      RETURN
      END
CDECK  ID>, R4DP.   
      FUNCTION C309R4(X,ETA,ZL,EPS,FCL,TPK1,ETANE0,LIMIT,ERR,NFP,
     1              FPMIN,FPMAX,LPR)
C
C ***   Evaluate CF1 = F'(ZL,ETA,X)/F(ZL,ETA,X)    (REAL)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      LOGICAL LPR,ETANE0

      FCL=1
      XI=1/X
      PK=ZL+1
      PX=PK+LIMIT
      EK=ETA/PK
      F=EK+PK*XI
      IF(ABS(F) .LT. FPMIN) F=FPMIN
      D=0
      C=F
      SMALL=SQRT(FPMIN)
      RK2=1+EK*EK
C
C ***   begin CF1 loop on PK = k = lambda + 1
C
   10 PK1=PK+1
      TPK1=PK+PK1
      IF(ETANE0) THEN
       EK=ETA/PK
       RK2=1+EK*EK
       TK=TPK1*(XI+EK/PK1)
      ELSE
       TK=TPK1*XI
      END IF
      C=TK-RK2/C
      D=TK-RK2*D
      IF(ABS(C) .LT. FPMIN) C=FPMIN
      IF(ABS(D) .LT. FPMIN) D=FPMIN
      D=1/D
      DF=D*C
      F=F*DF
      FCL=FCL*D*TPK1*XI
      IF(ABS(FCL) .LT. SMALL) FCL=FCL/SMALL
      IF(ABS(FCL) .GT. FPMAX) FCL=FCL*FPMIN
      PK=PK1
      IF(PK .LE. PX) THEN
       IF(ABS(DF-1) .GE. EPS) GO TO 10
       NFP=PK-ZL-1
       ERR=EPS*SQRT(REAL(NFP))
       C309R4=F
      ELSE
       IF(LPR) WRITE (6,1000) LIMIT,ABS(X)
       ERR=2
      END IF
      RETURN
 1000 FORMAT(1X,'***** CERN C309 WCLBES ... CF1 (REAL) HAS FAILED ',
     1'TO CONVERGE AFTER',I10,' ITERATIONS AS ABS(X) =',F15.0)
      END
CDECK  ID>, R5DP.   
      FUNCTION C309R5(X,ETA,ZL,EPS,FCL,TPK1,ETANE0,LIMIT,ERR,NFP,
     1              FPMIN,FPMAX,LPR)
C
C ***    Evaluate CF1  =  F'(ZL,ETA,X)/F(ZL,ETA,X)  (COMPLEX)
C
      IMPLICIT COMPLEX*16(A-H,O-Z)
      LOGICAL LPR,ETANE0
      DOUBLE PRECISION EPS,ERR,FPMIN,FPMAX,ABSC,SMALL,PX


      ABSC(W)=ABS(DREAL(W))+ABS(DIMAG(W))

      FCL=1
      XI=1/X
      PK=ZL+1
      PX=PK+LIMIT
      EK=ETA/PK
      F=EK+PK*XI
      IF(ABSC(F) .LT. FPMIN) F=FPMIN
      D=0
      C=F
      SMALL=SQRT(FPMIN)
      RK2=1+EK*EK
C
C ***   begin CF1 loop on PK = k = lambda + 1
C
   10 PK1=PK+1
      TPK1=PK+PK1
      IF(ETANE0) THEN
       EK=ETA/PK
       RK2=1+EK*EK
       TK=TPK1*(XI+EK/PK1)
      ELSE
       TK=TPK1*XI
      END IF
      C=TK-RK2/C
      D=TK-RK2*D
      IF(ABSC(C) .LT. FPMIN) C=FPMIN
      IF(ABSC(D) .LT. FPMIN) D=FPMIN
      D=1/D
      DF=D*C
      F=F*DF
      FCL=FCL*D*TPK1*XI
      IF(ABSC(FCL) .LT. SMALL) FCL=FCL/SMALL
      IF(ABSC(FCL) .GT. FPMAX) FCL=FCL*FPMIN
      PK=PK1
      IF(DREAL(PK) .LE. PX) THEN
       IF(ABSC(DF-1) .GE. EPS) GO TO 10
       NFP=PK-ZL-1
       ERR=EPS*SQRT(REAL(NFP))
       C309R5=F
      ELSE
       IF(LPR) WRITE (6,1000) LIMIT,ABS(X)
       ERR=2
      END IF
      RETURN
 1000 FORMAT(1X,'***** CERN C309 WCLBES ... CF1 (COMPLEX) HAS FAILED ',
     1'TO CONVERGE AFTER',I10,' ITERATIONS AS ABS(X) =',F15.0)
      END
CDECK  ID>, R6DP.   
      FUNCTION C309R6(RHO,ETA,XL,PSI,EPS,NMAX,NUSED,FCL,RE,FPMAX,XX,G,C)
C
C     evaluate the ASYMPTOTIC EXPANSION for the
C            LOGARITHMIC DERIVATIVE OF THE REGULAR SOLUTION
C
C ***        CF1A  =  f   =  F'(XL,ETA,RHO)/F(XL,ETA,RHO)
C
C      that is valid for DREAL(RHO)>0, and best for RHO >> ETA**2, XL,
C      and is derived from the 2F0 expansions for H+ and H-
C      e.g. by Froeberg (Rev. Mod. Physics Vol 27, p399 , 1955)
C      Some lines of this subprogram are for convenience copied from
C           Takemasa, Tamura & Wolter CPC 17 (1979) 351.
C
C     Evaluate to accuracy EPS with at most NMAX terms.
C
C     If the terms start diverging,
C     the corresponding continued fraction is found by RCF
C     & evaluated progressively by Steed's method to obtain convergence.
C
      IMPLICIT COMPLEX*16(A-H,O-Z)
      DIMENSION XX(2,NMAX),G(NMAX),C(NMAX)
      DOUBLE PRECISION RE,EPS,T1,T2,T3,AT,ATL,ABSC,FPMAX
      DOUBLE PRECISION HPI

      PARAMETER(HPI  = 1.57079 63267 94896 619D0)

      ABSC(W)=ABS(DREAL(W))+ABS(DIMAG(W))
C
      T1=SIN(DREAL(PSI))
      T2=COS(DREAL(PSI))
      ATL=TANH(DIMAG(PSI))

C         GIVE COS(PSI)/COSH(IM(PSI)), WHICH ALWAYS HAS CORRECT SIGN

      COSL=DCMPLX(T2,-T1*ATL)
      TANL=DCMPLX(T1,T2*ATL)/COSL
      RE=0
      XLL1=XL*XL+XL
      ETASQ=ETA*ETA
      SL1=1
      SL=SL1
      SC1=0
      SC=SC1
      TL1=SC
      TL=TL1
      TC1=1-ETA/RHO
      TC=TC1
      FCL=TL+SL*TANL
      G(1)=(TC+SC*TANL)/FCL
      GLAST=G(1)
      ATL=ABSC(GLAST)
      F=GLAST
      D=1
      DF=GLAST
      J=0
      DO 10 N = 2,NMAX
      T1=N-1
      T2=2*T1-1
      T3=T1*T1-T1
      DENOM=2*RHO*T1
      C1=(ETA*T2)/DENOM
      C2=(ETASQ+XLL1-T3)/DENOM
      SL2=C1*SL1-C2*TL1
      TL2=C1*TL1+C2*SL1
      SC2=C1*SC1-C2*TC1-SL2/RHO
      TC2=C1*TC1+C2*SC1-TL2/RHO
      SL=SL+SL2
      TL=TL+TL2
      SC=SC+SC2
      TC=TC+TC2
      SL1=SL2
      TL1=TL2
      SC1=SC2
      TC1=TC2
      FCL=TL+SL*TANL
      IF(ABSC(FCL) .GT. FPMAX .OR. ABSC(FCL) .LT. 1./FPMAX) THEN
       C309R6=G(1)
       FCL=1
       RE=1
       NUSED=0
       RETURN
      END IF
      GSUM=(TC+SC*TANL)/FCL
      G(N)=GSUM-GLAST
      GLAST=GSUM
      AT=ABSC(G(N))
      IF(AT .LT. ABSC(GSUM)*EPS) THEN
       FCL=FCL*COSL
       C309R6=GSUM
       RE=AT/ABSC(GSUM)
       NUSED=N
       RETURN
      END IF
      IF(J .GT. 0 .OR. AT .GT. ATL .OR. N .GE. NMAX-2) J=J+1
      IF(J .EQ. 0) GO TO 10
      CALL C309R7(G,C,J,N,XX,EPS)
      IF(N .LT. 0) THEN
       C309R6=G(1)
       FCL=1
       RE=1
       NUSED=0
       RETURN
      END IF
      DO 60 K = MAX(J,2),N
      D=1/(D*C(K)+1)
      DF=DF*D-DF
      F=F+DF
      IF(ABSC(DF) .LT. ABSC(F)*EPS .OR.
     1   DF .EQ. 0 .AND. F .EQ. 0 .AND. N .GE. 4) THEN
       C309R6=F
       FCL=FCL*COSL
       RE=ABSC(DF)/ABSC(F)
       NUSED=K
       RETURN
      END IF
   60 CONTINUE
      J=N
   10 ATL=AT
      C309R6=F
      FCL=FCL*COSL
      RE=ABSC(DF)/ABSC(F)
      NUSED=-NMAX
      RETURN
      END
CDECK  ID>, R7DP.   
      SUBROUTINE C309R7(A,B,IBEG,INUM,XX,EPS)
C
C*******************************************************************
C
C  RCF converts polynomial A to the corresponding continued
C         fraction, in 'normal'  form with coefficients B
C         by the 'P algorithm' of Patry & Gupta
C
C   A(z) = A1/z + A2/z**3 + A3/z**5 + ... + An/z**(2n-1)
C
C   B(z) = B1/z+ B2/z+ B3/z+ .../(z+ Bn/z)
C
C  data:
C   A     vector A(k), k=1,INUM         input
C   B     vector B(k), k=IBEG,INUM      output
C   IBEG  order of first coef. calc.    input
C   INUM  order of A, even or odd       input
C   XX    auxiliary vector of length .ge. length of vector B
C         caller provides space for A,B,XX
C   Note that neither of the first two terms A(1) A(2) should be zero
C          & the user can start the calculation with any value of
C          IBEG provided the c.f. coefs have been already
C          calculated up to INUM = IBEG-1
C          & the method breaks down as soon as the absolute value
C          of a c.f. coef. is less than EPS.    At the time of the
C          break up  INUM has been replaced by minus times the number
C          of this coefficient.
C   algorithm: J. Patry & S. Gupta, EIR-Bericht 247, November 1973
C              Eidg. Institut fur Reaktorforschung
C              Wuerenlingen, Switzerland
C   see also:  Haenggi, Roesel & Trautmann,
C              J. Comput. Phys., v. 137, (1980) 242-258
C   note:      restart procedure modified by I.J.Thompson
C
C*******************************************************************
C
      IMPLICIT COMPLEX*16(A-H,O-Z)
      DIMENSION A(100),B(100),XX(2,100)
      LOGICAL EVEN
      DOUBLE PRECISION EPS

      IBN=INUM
      IF(IBEG .GT. 4) GO TO 50
      IF(IBEG .EQ. 4) GO TO 20
      B(1)=A(1)
      IF(IBN .GE. 2) B(2)=-A(2)/A(1)
      IF(IBN .LT. 3) RETURN
      X0=A(3)/A(2)
      XX(2,1)=B(2)
      XX(1,1)=-X0
      XX(1,2)=0
      B(3)=-X0-B(2)
      X0=-B(3)*A(2)
      M=3
      MP12=2
      EVEN=.TRUE.
      IF(IBN .LE. 3) RETURN
   20 IF(ABS(B(3)) .LT. EPS*ABS(X0)) THEN
       INUM=-M
       RETURN
      END IF
      M=4
   30 X1=A(M)
      M2M1=MP12
      MP12=M2M1+1
      IF(EVEN) MP12=M2M1
      DO 40 K = 2,MP12
   40 X1=X1+A(M-K+1)*XX(1,K-1)
      B(M)=-X1/X0
      IF(M .GE. IBN) RETURN
   50 IF(ABS(B(M)) .LT. EPS*ABS(X0)) THEN
       INUM=-M
       RETURN
      END IF
      DO 60 K = M2M1,2,-1
   60 XX(2,K)=XX(1,K)+B(M)*XX(2,K-1)
      XX(2,1)=XX(1,1)+B(M)
      DO 70 K = 1,M2M1
      X0=XX(2,K)
      XX(2,K)=XX(1,K)
   70 XX(1,K)=X0
      X0=X1
      XX(1,M2M1+1)=0
      M=M+1
      EVEN=.NOT.EVEN
      GO TO 30
      END
CDECK  ID>, R8DP.   
      FUNCTION C309R8(Z,ACC)
      COMPLEX*16 C309R8,Z
      DOUBLE PRECISION ACC
      DOUBLE PRECISION X,Y,AX,AY,A

      X=DREAL(Z)
      Y=DIMAG(Z)
      AX=ABS(X)
      AY=ABS(Y)
      A=5*ACC*(AX+AY)
      IF(AX .LT. A) X=0
      IF(AY .LT. A) Y=0
      C309R8=DCMPLX(X,Y)
      RETURN
      END
CDECK  ID>, LEGFN.  
      SUBROUTINE LEGFN (V,Z,P,Q,NC,NF)
      COMMON/LEGBL/VV,ZZ,PP,QQ,ACC,NCVG,Z1,Z2,CVV,SVV,NFRIG,XDUMX,U
     1,PISR,PI,A,B,C,GR,R1,R2,R3,R4,ZZ1,ZZ2,SRZ
      COMPLEX VV,ZZ,PP,QQ,Z1,Z2,U,A,B,C,GR,CVV,SVV,ZZ1,ZZ2,SRZ
     1,V,Z,P,Q
     2,ZZS,CISP,CISM,PT,VVP,ZZZ
     3,CSQRTK
      DATA AC/0.0000001/
      DATA QINF / .1E36/
      CALL C311BD
      ACC=AC**2
      IF(REAL(V)+0.5) 16,17,17
   16 VV=-V-1.0
      GOTO 18
   17 VV=V
C---  It seems that NIC311 expects a REAL argument
C     NVV=NIC311(VV)
   18 NVV=NIC311(REAL(VV))
C*UL 30      VVP=VV*PI
      VVP=VV*PI
      GOTO (21,22,23,24,25),NVV
   21 SV=1.0
      GOTO 26
   23 SV=-1.0
   26 CV=0.0
      GOTO 28
   22 CV=-1.0
      GOTO 27
   24 CV=1.0
   27 SV=0.0
      GOTO 28
   25 SV=SIN(REAL(VVP))
      CV=COS(REAL(VVP))
   28 EIP=EXP(AIMAG(VVP))
      EIM=EXP(-AIMAG(VVP))
      SHV=0.5*(EIP-EIM)
      CHV=0.5*(EIP+EIM)
      SVV=SV*CHV+U*CV*SHV
      CVV=CV*CHV-U*SV*SHV
      CISP=CVV+U*SVV
      CISM=CVV-U*SVV
      IF(REAL(Z))9,10,11
    9 ZZ=-Z
      N23=3
      NFF=-NF
      GOTO 12
   10 N24=4
      ZZ=Z
      IF(AIMAG(ZZ))13,77,13
   11 ZZ=Z
      N23=2
      NFF=NF
   12 N24=2
   13 ZZS=ZZ**2
      Z1=(1.0-ZZ)/2.0
      IF(AIMAG(ZZ))7,6,7
    6 IF(REAL(Z1))4,70,5
    4 NFRIG=SIGN(N23,NFF)
      GOTO 8
    5 NFRIG=NFF
      GOTO 8
    7 NFRIG=SIGN(REAL(N24),AIMAG(ZZ))
    8 Z2=1.0/ZZS
      SRZ=CSQRTK(ZZS-1.0,NFRIG,1)
      ZZ1=(ZZ+SRZ)/(2.0*SRZ)
      ZZ2=(-ZZ+SRZ)/(2.0*SRZ)
      IF(REAL(Z))1,2,2
    1 SRZ=-SRZ
    2 ZZZ=ZZ
      ZZ=Z
      VR=REAL(VV)**2
      VI=AIMAG(VV)**2
      R1=ABS(Z1)
      R2=ABS(Z2)
      R3=ABS(ZZ1)
      R4=ABS(ZZ2)
      IF(R1-R2)61,61,62
   61 RR=MAX(R3,R4)/0.045-19.5
      IF(RR)66,66,65
   65 VRI=VR+VI
      IF(VRI)165,67,165
  165 IF(RR**2-VRI+VI**2/(2.0*VRI))66,67,67
   66 CALL LEGV
      IF(NCVG)166,97,166
  166 ZZ=ZZZ
      CALL LEG1
      GOTO 90
   67 ZZ=ZZZ
      CALL LEG1
      IF(NCVG)167,90,167
  167 ZZ=Z
      CALL LEGV
      GOTO 97
   62 IF(VR+VI-16.0*R2**2)63,64,64
   64 CALL LEGV
      IF(NCVG)164,97,164
  164 CALL LEGZ
      GOTO 97
   63 CALL LEGZ
      IF(NCVG)163,97,163
  163 CALL LEGV
      GOTO 97
   90 IF(REAL(Z)) 93,97,97
   93 PT=-2.0/PI*SVV*QQ
      IF(NFRIG) 94,95,96
   94 PP=CISP*PP+PT
      QQ=-CISM*QQ
      GOTO 97
   95 QQ=-CVV*QQ-PI/2.0*SVV*PP
      PP=CVV*PP+PT
      GOTO 97
   96 PP=CISM*PP+PT
      QQ=-CISP*QQ
      GOTO 97
   97 IF(REAL(V)+0.5) 91,92,92
   91 IF(ABS(SVV).NE.0.) GOTO 98
      QQ=QINF
      GOTO 92
   98 QQ=(QQ*SVV-PI*CVV*PP)/SVV
   92 P=PP
      Q=QQ
      NC=NCVG
      RETURN
   70 QQ=QINF
C
      IF(REAL(Z))173,173,74
  173 IF(AIMAG(V))71,73,71
   73 GOTO (71,72,71,74,71),NVV
   71 PP=QQ
      GOTO 82
   72 PP=-1.0
      GOTO 82
   74 PP=1.0
      GOTO 82
   77 NFRIG=NF
      CALL LEGOR
   82 NCVG=0
      GOTO 92
      END
CDECK  ID>, C311BD. 
      SUBROUTINE C311BD
      COMMON/LEGBL/VV,ZZ,PP,QQ,ACC,NCVG,Z1,Z2,CVV,SVV,NFRIG,XDUMX,U
     1,PISR,PI,A,B,C,GR,R1,R2,R3,R4,ZZ1,ZZ2,SRZ
      COMPLEX VV,ZZ,PP,QQ,Z1,Z2,U,A,B,C,GR,CVV,SVV,ZZ1,ZZ2,SRZ
      DATA IBD/0/
      IF(IBD.NE.0) RETURN
      IBD=1
      PISR=1.7724 53850 90552
      PI=3.141592653589793
      U=(0.0,1.0)
      RETURN
      END
CDECK  ID>, LEG1.   
      SUBROUTINE LEG1
      COMMON/LEGBL/VV,ZZ,PP,QQ,ACC,NCVG,Z1,Z2,CVV,SVV,NFRIG,XDUMX,U
     1,PISR,PI,A,B,C,GR,R1,R2,R3,R4,ZZ1,ZZ2,SRZ
      COMPLEX VV,ZZ,PP,QQ,Z1,Z2,U,A,B,C,GR,CVV,SVV,ZZ1,ZZ2,SRZ
     1,SIGMA,FAC
     2,CLOGOK,CDIGAM
      DATA GAMMA/0.5772156649/
      A=-VV
      B=VV+1.0
      C=(1.0,0.0)
      CALL HYPGM(A,B,C,Z1,PP,ACC,NCVG)
      SIGMA=(0.0,0.0)
      FAC=(1.0,0.0)
      A=0.5*CLOGOK((ZZ+1.0)/(ZZ-1.0),NFRIG,1)-GAMMA-CDIGAM(B)
      QQ=A
      DO 17 L=1,50
      EL=L
      SIGMA=SIGMA+1.0/EL
      FAC=-FAC*(VV+EL)*(VV-EL+1.0)*Z1/(EL*EL)
      B=(A+SIGMA)*FAC
      QQ=QQ+B
      IF(CRIT(QQ,B,ACC))80,17,17
   17 CONTINUE
      NCVG=NCVG+2
   80 RETURN
      END
CDECK  ID>, LEGV.   
      SUBROUTINE LEGV
      COMMON/LEGBL/VV,ZZ,PP,QQ,ACC,NCVG,Z1,Z2,CVV,SVV,NFRIG,XDUMX,U
     1,PISR,PI,A,B,C,GR,R1,R2,R3,R4,ZZ1,ZZ2,SRZ
      COMPLEX VV,ZZ,PP,QQ,Z1,Z2,U,A,B,C,GR,CVV,SVV,ZZ1,ZZ2,SRZ
     1,F1,F2,SSRZ
     2,CLOGOK,CSQRTK,RGAM
      A=0.5
      C=VV+1.5
      CALL HYPGM(A,A,C,ZZ1,F1,ACC,NCVG)
      CALL HYPGM(A,A,C,ZZ2,F2,ACC,NCV )
      NCVG=NCVG+2*NCV
C*UL6 F1=F1*EXP((VV+0.5)*CLOGOK(ZZ +SRZ,NFRIG,3))
      F1=F1*EXP((VV+0.5)*CLOGOK(ZZ +SRZ,NFRIG,3))
      F2=F2*EXP((VV+0.5)*CLOGOK(ZZ -SRZ,-NFRIG,3))
      A=1.5
      B=1.0
      SSRZ=CSQRTK(2.0*SRZ,NFRIG,2)*RGAM(VV,A,B)
      SGN=1.0
      IF(AIMAG(ZZ))8,14,12
    8 SGN=-1.0
      GOTO 12
   14 SGN=SIGN(1.0,(NFRIG+0.5)*REAL(ZZ))
   12 PP=(F1+SGN*U*F2)/(PISR*SSRZ)
      IF(NFRIG)11,10,11
   10 QQ=0.5*PISR*(F2+SGN*U*F1)/SSRZ
      GOTO 80
   11 QQ=PISR*F2/SSRZ
   80 RETURN
      END
CDECK  ID>, LEGZ.   
      SUBROUTINE LEGZ
      COMMON/LEGBL/VV,ZZ,PP,QQ,ACC,NCVG,Z1,Z2,CVV,SVV,NFRIG,XDUMX,U
     1,PISR,PI,A,B,C,GR,R1,R2,R3,R4,ZZ1,ZZ2,SRZ
      COMPLEX VV,ZZ,PP,QQ,Z1,Z2,U,A,B,C,GR,CVV,SVV,ZZ1,ZZ2,SRZ
     1,F1,F2,ZV
     2,CLOGOK,RGAM
      GR=CLOGOK(2.0*ZZ,NFRIG,2)
      A=1.5
      B=1.0
      ZV=RGAM(VV,A,B)*EXP(VV*GR)
      A=VV/2.0+1.0
      B=VV/2.0+0.5
      C=VV+1.5
      ACCC=ACC/100.
      CALL HYPGM(A,B,C,Z2,F1,ACCC,NCVG)
      F1=F1/(2.0*ZZ*ZV)
      QQ=PISR*F1
      IF(ABS(CVV).GT.0.001) GOTO 9
C   TRDZ EXPECTS GR=CLOGOK(2.0*ZZ,NFRIG,2) BUT DESTROYS CONTENTS
      CALL TRDZ
      GOTO 80
    9 A=-VV/2.0
      B=(1.0-VV)/2.0
      C=0.5-VV
      CALL HYPGM(A,B,C,Z2,F2,ACCC,NCV )
      NCVG=NCVG+2*NCV
      F2=F2*ZV/(VV+0.5)
      PP=(F1*SVV/CVV+F2)/PISR
   80 RETURN
      END
CDECK  ID>, TRDZ.   
      SUBROUTINE TRDZ
      COMMON/LEGBL/VV,ZZ,PP,QQ,ACC,NCVG,Z1,Z2,CVV,SVV,NFRIG,XDUMX,U
     1,PISR,PI,A,B,C,GR,R1,R2,R3,R4,ZZ1,ZZ2,SRZ
      COMPLEX VV,ZZ,PP,QQ,Z1,Z2,U,A,B,C,GR,CVV,SVV,ZZ1,ZZ2,SRZ
     1,EP
     2,       RGAM,CDIGAM
     3,EP2,PIE,ZZS2,AA,BB,CC,FAC,SUM,ADD
C*NS 2,CLOGOK,RGAM,CDIGAM
C   TRDZ  EXPECTS GR SET=CLOGOK(2.0*ZZ,NFRIG,2)
      K=REAL(VV+1.0)
      EK=K
      EP=VV+0.5-EK
      ZZS2=Z2/4.0
      KK=K-1
      SUM=0.0
      IF(K)9,9,10
   10 B=0.5
      C=1.0
      FAC=RGAM(VV,B,C)*EXP(VV*GR)
      SUM=FAC
      IF(KK)9,11,12
   12 AA=-VV-2.0
      BB=-VV-0.5
      DO 2 I=1,KK
      BB=BB+1.0
      AA=AA+2.0
      FAC=FAC*(1.0+AA)*AA*ZZS2/(BB*I)
      SUM=SUM+FAC
      IF(CRIT(SUM,FAC,ACC))51,2,2
    2 CONTINUE
      GOTO 11
    9 SUM=0.0
   51 CONTINUE
   11 PIE=PI*EP
      EP2=EP/2.0
      A=EK
      B=0.5-EP
      C=1.0
      BB=0.0
      FAC=-(1.0-PIE**2/3.0)*RGAM(A,B,C)*RGAM(C,BB,-EP)
     1                 / (PI*EXP((2.0*EK-VV)*GR))
      A=EK+0.5
      B=1.0-EP2
      C=EK+1.0+EP2
      ADD=2.*CDIGAM(A)-CDIGAM(B)-CDIGAM(C)-2.0*GR
      GR=FAC*ADD*(1.0+EP2*ADD)
      SUM=SUM+GR
      AA=EK-1.5-EP
      BB=-EP
      CC=EK
      DO 22 I=1,50
      AA=AA+2.0
      BB=BB+1.0
      CC=CC+1.0
      FAC=FAC*(1.0+AA)*AA*ZZS2/(BB*CC)
      ADD=ADD+2.0/(A+1.0)+2.0/A-1.0/B-1.0/C
      A=A+2.0
      B=B+1.0
      C=C+1.0
      GR=FAC*ADD*(1.0+EP2*ADD)
      SUM=SUM+GR
      IF(CRIT(SUM,GR,ACC))52,22,22
   22 CONTINUE
      NCVG=NCVG+4
   52 PP=SUM/PISR
      RETURN
      END
CDECK  ID>, HYPGM.  
      SUBROUTINE HYPGM(A,B,C,Z,H,ACC,NCVG)
      COMPLEX A,B,C,Z,H,AA,BB,CC,ZZ,ADD,DD,HH
      NCVG=0
      ZZ=Z
      HH=(1.0,0.0)
      AA=A
      BB=B
      CC=C
      ADD=(1.0,0.0)
      DD=(1.0,0.0)
      DO 21 I=1,50
      ADD=ADD*ZZ*AA/DD*BB/CC
      HH=HH+ADD
      IF(CRIT(HH,ADD,ACC))3,4,4
    4 AA=AA+1.0
      BB=BB+1.0
      CC=CC+1.0
      DD=DD+1.0
   21 CONTINUE
      NCVG=1
    3 H=HH
      RETURN
      END
CDECK  ID>, CRIT.   
      FUNCTION CRIT(SUM,DEL,ACCS)
      COMPLEX SUM,DEL
      CRIT=REAL(DEL)**2+AIMAG(DEL)**2-ACCS*(REAL(SUM)**2+AIMAG(SUM)**2)
      RETURN
      END
CDECK  ID>, NIC311. 
      FUNCTION NIC311(X)
C     X=1/2 OF 4N+1 SET NIC311=1
C     X=1/2 OF 4N+2 SET NIC311=2
C     X=1/2 OF 4N+3 SET NIC311=3
C     X=1/2 OF 4N+4 SET NIC311=4
C     OTHERWISE SET NIC311=5
      Y=X+X
      N=INT(Y)
      IF(Y-N)9,10,9
    9 NIC311=5
      RETURN
   10 NIC311=MOD(N,4)
      IF(NIC311.LE.0) NIC311=4+NIC311
      RETURN
      END
CDECK  ID>, CSQRTK. 
      COMPLEX FUNCTION CSQRTK(Z,N,M)
      COMPLEX Z,SZ
      NF=N+5
      SZ=SQRT(Z)
      S=ABS(AIMAG(SZ))
      GOTO (21,22),M
   21 GOTO (9,2,2,9,11,11,2,2,11),NF
   22 GOTO (2,11,2,2,2,2,2,9,2),NF
    9 SZ=CMPLX(0.0,-S)
      GOTO 2
   11 SZ=CMPLX(0.0,S)
    2 CSQRTK=SZ
      RETURN
      END
CDECK  ID>, CLOGOK. 
      COMPLEX FUNCTION CLOGOK(Z,N,M)
      COMPLEX Z,SZ
      DATA PI/3.1415926535898/
      SZ=LOG(Z)
      S=REAL(SZ)
      NF=N+5
      GOTO (21,22,23) ,M
   21 GOTO (2,2,2,11,10,9,2,2,2),NF
   22 GOTO (2,11,2,2,2,2,2,9,2),NF
   23 GOTO (2,11,2,2,2,2,2,9,2),NF
    9 SZ=CMPLX(S,-PI)
      GOTO 2
   10 SZ=CMPLX(S,0.0)
      GOTO 2
   11 SZ=CMPLX(S,PI)
    2 CLOGOK=SZ
C*UL  80  RETURN
      RETURN
      END
CDECK  ID>, LEGOR.  
      SUBROUTINE LEGOR
      COMMON/LEGBL/VV,ZZ,PP,QQ,ACC,NCVG,Z1,Z2,CVV,SVV,NFRIG,XDUMX,U
     1,PISR,PI,A,B,C,GR,R1,R2,R3,R4,ZZ1,ZZ2,SRZ
      COMPLEX VV,ZZ,PP,QQ,Z1,Z2,U,A,B,C,GR,CVV,SVV,ZZ1,ZZ2,SRZ
     1,RGAM
      A=0.5*(1.0+VV)
      B=0.0
      C=0.5
      GR=RGAM(A,B,C)
      C=U*PI*VV*0.5
      A=EXP(C)
      B=EXP(-C)
      IF(NFRIG)9,10,11
    9 QQ=PISR*0.5*GR*U*A
      GOTO 12
   10 QQ=U*PISR/4.0*GR*(A-B)
      GOTO 12
   11 QQ=-PISR/2.0*GR*B*U
   12 PP=GR*(A+B)/(2.0*PISR)
      RETURN
      END
CDECK  ID>, RGAM.   
      COMPLEX FUNCTION RGAM(Z,A,B)

      COMPLEX Z,A,B,CLOGAM

      RGAM=EXP(CLOGAM(Z+A)-CLOGAM(Z+B))
      RETURN
      END
CDECK  ID>, BESJ0.  
      FUNCTION BESJ0(X)
      DOUBLE PRECISION
     +     D,DBESJ0,DBESJ1,DBESY0,DBESY1

      SROUND(D)=D+(D-SNGL(D))
      BESJ0=SROUND(DBESJ0(DBLE(X)))
      RETURN

      ENTRY BESJ1(X)
      BESJ1=SROUND(DBESJ1(DBLE(X)))
      RETURN

      ENTRY BESY0(X)
      BESY0=SROUND(DBESY0(DBLE(X)))
      RETURN

      ENTRY BESY1(X)
      BESY1=SROUND(DBESY1(DBLE(X)))
      RETURN
      END
CDECK  ID>, BESJ064.
      FUNCTION DBESJ0(X)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMPLEX*16
     +  C,F,I,CB0,CB1,CB2
      CHARACTER NAME0*(*),NAME1*(*)
      CHARACTER*80 ERRTXT
      LOGICAL LJ0,LY0,LJ1,LY1
      DIMENSION A(0:16),B(0:16),C(0:19),D(0:16),E(0:16),F(0:19)

      PARAMETER (NAME0 = 'BESY0/DBESY0', NAME1 = 'BESY1/DBESY1')
      PARAMETER (I = (0,1))
      PARAMETER (Z1 = 1, HF = Z1/2, R8 = Z1/8, R32 = Z1/32)
      PARAMETER (CE = 0.57721 56649 01532 861D0)
      PARAMETER (PI = 3.14159 26535 89793 238D0)
      PARAMETER (PI1 = 2/PI, PI3 = 3*PI/4, PI4 = PI/4)

      DATA A( 0) /+0.15772 79714 74890 120D0/
      DATA A( 1) /-0.00872 34423 52852 221D0/
      DATA A( 2) /+0.26517 86132 03336 810D0/
      DATA A( 3) /-0.37009 49938 72649 779D0/
      DATA A( 4) /+0.15806 71023 32097 261D0/
      DATA A( 5) /-0.03489 37694 11408 885D0/
      DATA A( 6) /+0.00481 91800 69467 605D0/
      DATA A( 7) /-0.00046 06261 66206 275D0/
      DATA A( 8) /+0.00003 24603 28821 005D0/
      DATA A( 9) /-0.00000 17619 46907 762D0/
      DATA A(10) /+0.00000 00760 81635 924D0/
      DATA A(11) /-0.00000 00026 79253 531D0/
      DATA A(12) /+0.00000 00000 78486 963D0/
      DATA A(13) /-0.00000 00000 01943 835D0/
      DATA A(14) /+0.00000 00000 00041 253D0/
      DATA A(15) /-0.00000 00000 00000 759D0/
      DATA A(16) /+0.00000 00000 00000 012D0/

      DATA B( 0) /-0.02150 51114 49657 551D0/
      DATA B( 1) /-0.27511 81330 43518 791D0/
      DATA B( 2) /+0.19860 56347 02554 156D0/
      DATA B( 3) /+0.23425 27461 09021 802D0/
      DATA B( 4) /-0.16563 59817 13650 413D0/
      DATA B( 5) /+0.04462 13795 40669 282D0/
      DATA B( 6) /-0.00693 22862 91523 188D0/
      DATA B( 7) /+0.00071 91174 03752 303D0/
      DATA B( 8) /-0.00005 39250 79722 939D0/
      DATA B( 9) /+0.00000 30764 93288 108D0/
      DATA B(10) /-0.00000 01384 57181 230D0/
      DATA B(11) /+0.00000 00050 51054 369D0/
      DATA B(12) /-0.00000 00001 52582 850D0/
      DATA B(13) /+0.00000 00000 03882 867D0/
      DATA B(14) /-0.00000 00000 00084 429D0/
      DATA B(15) /+0.00000 00000 00001 587D0/
      DATA B(16) /-0.00000 00000 00000 026D0/

      DATA
     + C( 0)/ (+0.99898 80898 58965 153D0, -0.01233 15205 78544 144D0)/,
     1 C( 1)/ (-0.00133 84285 49971 856D0, -0.01224 94962 81259 475D0)/,
     2 C( 2)/ (-0.00031 87898 78061 893D0, +0.00009 64941 84993 423D0)/,
     3 C( 3)/ (+0.00000 85112 32210 657D0, +0.00001 36555 70490 357D0)/,
     4 C( 4)/ (+0.00000 06915 42349 139D0, -0.00000 08518 06644 426D0)/,
     5 C( 5)/ (-0.00000 00907 70101 537D0, -0.00000 00272 44053 414D0)/,
     6 C( 6)/ (+0.00000 00014 54928 079D0, +0.00000 00096 46421 338D0)/,
     7 C( 7)/ (+0.00000 00009 26762 487D0, -0.00000 00006 83347 518D0)/,
     8 C( 8)/ (-0.00000 00001 39166 198D0, -0.00000 00000 60627 380D0)/,
     9 C( 9)/ (+0.00000 00000 03237 975D0, +0.00000 00000 21695 716D0)/,
     * C(10)/ (+0.00000 00000 02535 357D0, -0.00000 00000 02304 899D0)/
      DATA
     A C(11)/ (-0.00000 00000 00559 090D0, -0.00000 00000 00122 554D0)/,
     B C(12)/ (+0.00000 00000 00041 919D0, +0.00000 00000 00092 314D0)/,
     C C(13)/ (+0.00000 00000 00008 733D0, -0.00000 00000 00016 778D0)/,
     D C(14)/ (-0.00000 00000 00003 619D0, +0.00000 00000 00000 754D0)/,
     E C(15)/ (+0.00000 00000 00000 594D0, +0.00000 00000 00000 462D0)/,
     F C(16)/ (-0.00000 00000 00000 010D0, -0.00000 00000 00000 159D0)/,
     G C(17)/ (-0.00000 00000 00000 024D0, +0.00000 00000 00000 025D0)/,
     H C(18)/ (+0.00000 00000 00000 008D0, +0.00000 00000 00000 000D0)/,
     I C(19)/ (-0.00000 00000 00000 001D0, -0.00000 00000 00000 001D0)/

      DATA D( 0) /+0.64835 87706 05264 921D0/
      DATA D( 1) /-1.19180 11605 41216 873D0/
      DATA D( 2) /+1.28799 40988 57677 620D0/
      DATA D( 3) /-0.66144 39341 34543 253D0/
      DATA D( 4) /+0.17770 91172 39728 283D0/
      DATA D( 5) /-0.02917 55248 06154 208D0/
      DATA D( 6) /+0.00324 02701 82683 857D0/
      DATA D( 7) /-0.00026 04443 89348 581D0/
      DATA D( 8) /+0.00001 58870 19239 932D0/
      DATA D( 9) /-0.00000 07617 58780 540D0/
      DATA D(10) /+0.00000 00294 97070 073D0/
      DATA D(11) /-0.00000 00009 42421 298D0/
      DATA D(12) /+0.00000 00000 25281 237D0/
      DATA D(13) /-0.00000 00000 00577 740D0/
      DATA D(14) /+0.00000 00000 00011 386D0/
      DATA D(15) /-0.00000 00000 00000 196D0/
      DATA D(16) /+0.00000 00000 00000 003D0/

      DATA E( 0) /-0.04017 29465 44414 076D0/
      DATA E( 1) /-0.44444 71476 30558 063D0/
      DATA E( 2) /-0.02271 92444 28417 736D0/
      DATA E( 3) /+0.20664 45410 17490 520D0/
      DATA E( 4) /-0.08667 16970 56948 524D0/
      DATA E( 5) /+0.01763 67030 03163 134D0/
      DATA E( 6) /-0.00223 56192 94485 095D0/
      DATA E( 7) /+0.00019 70623 02701 541D0/
      DATA E( 8) /-0.00001 28858 53299 241D0/
      DATA E( 9) /+0.00000 06528 47952 359D0/
      DATA E(10) /-0.00000 00264 50737 175D0/
      DATA E(11) /+0.00000 00008 78030 117D0/
      DATA E(12) /-0.00000 00000 24343 279D0/
      DATA E(13) /+0.00000 00000 00572 612D0/
      DATA E(14) /-0.00000 00000 00011 578D0/
      DATA E(15) /+0.00000 00000 00000 203D0/
      DATA E(16) /-0.00000 00000 00000 003D0/
      DATA
     + F( 0)/ (+1.00170 22348 53820 996D0, +0.03726 17150 00537 654D0)/,
     1 F( 1)/ (+0.00225 55728 46561 180D0, +0.03714 53224 79807 690D0)/,
     2 F( 2)/ (+0.00054 32164 87508 013D0, -0.00013 72632 38201 907D0)/,
     3 F( 3)/ (-0.00001 11794 61895 408D0, -0.00001 98512 94687 597D0)/,
     4 F( 4)/ (-0.00000 09469 01382 392D0, +0.00000 10700 14057 386D0)/,
     5 F( 5)/ (+0.00000 01110 32677 121D0, +0.00000 00383 05261 714D0)/,
     6 F( 6)/ (-0.00000 00012 94398 927D0, -0.00000 00116 28723 277D0)/,
     7 F( 7)/ (-0.00000 00011 14905 944D0, +0.00000 00007 59733 092D0)/,
     8 F( 8)/ (+0.00000 00001 57637 232D0, +0.00000 00000 75476 075D0)/,
     9 F( 9)/ (-0.00000 00000 02830 457D0, -0.00000 00000 24752 781D0)/
      DATA
     * F(10)/ (-0.00000 00000 02932 169D0, +0.00000 00000 02493 893D0)/,
     A F(11)/ (+0.00000 00000 00617 809D0, +0.00000 00000 00156 198D0)/,
     B F(12)/ (-0.00000 00000 00043 162D0, -0.00000 00000 00103 385D0)/,
     C F(13)/ (-0.00000 00000 00010 133D0, +0.00000 00000 00018 129D0)/,
     D F(14)/ (+0.00000 00000 00003 973D0, -0.00000 00000 00000 709D0)/,
     E F(15)/ (-0.00000 00000 00000 632D0, -0.00000 00000 00000 520D0)/,
     F F(16)/ (+0.00000 00000 00000 006D0, +0.00000 00000 00000 172D0)/,
     G F(17)/ (+0.00000 00000 00000 027D0, -0.00000 00000 00000 026D0)/,
     H F(18)/ (-0.00000 00000 00000 008D0, -0.00000 00000 00000 000D0)/,
     I F(19)/ (+0.00000 00000 00000 001D0, +0.00000 00000 00000 001D0)/

      LJ0=.TRUE.
      LY0=.FALSE.
      GO TO 11

      ENTRY DBESY0(X)
      LJ0=.FALSE.
      LY0=.TRUE.
      IF(X .LE. 0) THEN
       P=0
       WRITE(ERRTXT,101) X
       CALL MTLPRT(NAME0,'C312.1',ERRTXT)
       GO TO 9
      END IF

   11 V=ABS(X)
      IF(V .LT. 8) THEN
       H=R32*V**2-1
       ALFA=H+H
       B1=0
       B2=0
       DO 1 IT = 16,0,-1
       B0=A(IT)+ALFA*B1-B2
       B2=B1
    1  B1=B0
       P=B0-H*B2
       IF(LY0) THEN
        B1=0
        B2=0
        DO 2 IT = 16,0,-1
        B0=B(IT)+ALFA*B1-B2
        B2=B1
    2   B1=B0
        P=PI1*(CE+LOG(HF*X))*P+B0-H*B2
       ENDIF
      ELSE
       R=1/V
       H=10*R-1
       ALFA=H+H
       CB1=0
       CB2=0
       DO 3 IT = 19,0,-1
       CB0=C(IT)+ALFA*CB1-CB2
       CB2=CB1
    3  CB1=CB0
       CB0=SQRT(PI1*R)*EXP(I*(V-PI4))*(CB0-H*CB2)
       IF(LJ0) P=CB0
       IF(LY0) P=-I*CB0
      ENDIF
      GO TO 9

      ENTRY DBESJ1(X)

      LJ1=.TRUE.
      LY1=.FALSE.
      GO TO 12

      ENTRY DBESY1(X)
      LJ1=.FALSE.
      LY1=.TRUE.
      IF(X .LE. 0) THEN
       P=0
       WRITE(ERRTXT,101) X
       CALL MTLPRT(NAME1,'C312.1',ERRTXT)
       GO TO 9
      END IF

   12 V=ABS(X)
      IF(V .LT. 8) THEN
       Y=R8*V
       H=2*Y**2-1
       ALFA=H+H
       B1=0
       B2=0
       DO 4 IT = 16,0,-1
       B0=D(IT)+ALFA*B1-B2
       B2=B1
    4  B1=B0
       P=Y*(B0-H*B2)
       IF(LY1) THEN
        B1=0
        B2=0
        DO 5 IT = 16,0,-1
        B0=E(IT)+ALFA*B1-B2
        B2=B1
    5   B1=B0
        P=PI1*((CE+LOG(HF*X))*P-1/X)+Y*(B0-B2)
       ENDIF
      ELSE
       R=1/V
       H=10*R-1
       ALFA=H+H
       CB1=0
       CB2=0
       DO 6 IT = 19,0,-1
       CB0=F(IT)+ALFA*CB1-CB2
       CB2=CB1
    6  CB1=CB0
       CB0=SQRT(PI1*R)*EXP(I*(V-PI3))*(CB0-H*CB2)
       IF(LJ1) P=CB0
       IF(LY1) P=-I*CB0
      ENDIF
      IF(X .LT. 0) P=-P
    9 CONTINUE
      DBESJ0=P
      RETURN
  101 FORMAT('NON-POSITIVE ARGUMENT X = ',1P,E15.6)
      END
CDECK  ID>, C313.   
C                  Orders Zero and One
CDECK  ID>, BESI0.  
      FUNCTION BESI0(X)
      IMPLICIT DOUBLE PRECISION (D)

      SROUND(D)=D+(D-SNGL(D))
      BESI0=SROUND(DBESI0(DBLE(X)))
      RETURN

      ENTRY BESI1(X)
      BESI1=SROUND(DBESI1(DBLE(X)))
      RETURN

      ENTRY EBESI0(X)
      EBESI0=SROUND(DEBSI0(DBLE(X)))
      RETURN

      ENTRY EBESI1(X)
      EBESI1=SROUND(DEBSI1(DBLE(X)))
      RETURN

      ENTRY BESK0(X)
      BESK0=SROUND(DBESK0(DBLE(X)))
      RETURN

      ENTRY BESK1(X)
      BESK1=SROUND(DBESK1(DBLE(X)))
      RETURN

      ENTRY EBESK0(X)
      EBESK0=SROUND(DEBSK0(DBLE(X)))
      RETURN

      ENTRY EBESK1(X)
      EBESK1=SROUND(DEBSK1(DBLE(X)))
      RETURN
      END
CDECK  ID>, BESI064.
      FUNCTION DBESI0(X)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL LEX
      CHARACTER NAME0*(*),NAME1*(*),NAME0E*(*),NAME1E*(*)
      CHARACTER*80 ERRTXT
      DIMENSION CI(0:24,0:1),CK(0:16,0:1)

      PARAMETER (NAME0 = 'BESK0/DBESK0', NAME0E = 'EBESK0/DBESK0')
      PARAMETER (NAME1 = 'BESK1/DBESK1', NAME1E = 'EBESK1/DBESK1')
      PARAMETER (EPS=1D-15)
      PARAMETER (Z1 = 1, HF = Z1/2)
      PARAMETER (PI = 3.14159 26535 89793 24D0)
      PARAMETER (CE = 0.57721 56649 01532 86D0)
      PARAMETER (PIH = PI/2, RPIH = 2/PI, RPI2 = 1/(2*PI))

      DATA CI( 0,0) /+1.00827 92054 58740 032D0/
      DATA CI( 1,0) /+0.00844 51226 24920 943D0/
      DATA CI( 2,0) /+0.00017 27006 30777 567D0/
      DATA CI( 3,0) /+0.00000 72475 91099 959D0/
      DATA CI( 4,0) /+0.00000 05135 87726 878D0/
      DATA CI( 5,0) /+0.00000 00568 16965 808D0/
      DATA CI( 6,0) /+0.00000 00085 13091 223D0/
      DATA CI( 7,0) /+0.00000 00012 38425 364D0/
      DATA CI( 8,0) /+0.00000 00000 29801 672D0/
      DATA CI( 9,0) /-0.00000 00000 78956 698D0/
      DATA CI(10,0) /-0.00000 00000 33127 128D0/
      DATA CI(11,0) /-0.00000 00000 04497 339D0/
      DATA CI(12,0) /+0.00000 00000 01799 790D0/
      DATA CI(13,0) /+0.00000 00000 00965 748D0/
      DATA CI(14,0) /+0.00000 00000 00038 604D0/
      DATA CI(15,0) /-0.00000 00000 00104 039D0/
      DATA CI(16,0) /-0.00000 00000 00023 950D0/
      DATA CI(17,0) /+0.00000 00000 00009 554D0/
      DATA CI(18,0) /+0.00000 00000 00004 443D0/
      DATA CI(19,0) /-0.00000 00000 00000 859D0/
      DATA CI(20,0) /-0.00000 00000 00000 709D0/
      DATA CI(21,0) /+0.00000 00000 00000 087D0/
      DATA CI(22,0) /+0.00000 00000 00000 112D0/
      DATA CI(23,0) /-0.00000 00000 00000 012D0/
      DATA CI(24,0) /-0.00000 00000 00000 018D0/

      DATA CI( 0,1) /+0.97580 06023 26285 926D0/
      DATA CI( 1,1) /-0.02446 74429 63276 385D0/
      DATA CI( 2,1) /-0.00027 72053 60763 829D0/
      DATA CI( 3,1) /-0.00000 97321 46728 020D0/
      DATA CI( 4,1) /-0.00000 06297 24238 640D0/
      DATA CI( 5,1) /-0.00000 00659 61142 154D0/
      DATA CI( 6,1) /-0.00000 00096 13872 919D0/
      DATA CI( 7,1) /-0.00000 00014 01140 901D0/
      DATA CI( 8,1) /-0.00000 00000 47563 167D0/
      DATA CI( 9,1) /+0.00000 00000 81530 681D0/
      DATA CI(10,1) /+0.00000 00000 35408 148D0/
      DATA CI(11,1) /+0.00000 00000 05102 564D0/
      DATA CI(12,1) /-0.00000 00000 01804 409D0/
      DATA CI(13,1) /-0.00000 00000 01023 594D0/
      DATA CI(14,1) /-0.00000 00000 00052 678D0/
      DATA CI(15,1) /+0.00000 00000 00107 094D0/
      DATA CI(16,1) /+0.00000 00000 00026 120D0/
      DATA CI(17,1) /-0.00000 00000 00009 561D0/
      DATA CI(18,1) /-0.00000 00000 00004 713D0/
      DATA CI(19,1) /+0.00000 00000 00000 829D0/
      DATA CI(20,1) /+0.00000 00000 00000 743D0/
      DATA CI(21,1) /-0.00000 00000 00000 080D0/
      DATA CI(22,1) /-0.00000 00000 00000 117D0/
      DATA CI(23,1) /+0.00000 00000 00000 011D0/
      DATA CI(24,1) /+0.00000 00000 00000 019D0/

      DATA CK( 0,0) /+0.98840 81742 30825 800D0/
      DATA CK( 1,0) /-0.01131 05046 46928 281D0/
      DATA CK( 2,0) /+0.00026 95326 12762 724D0/
      DATA CK( 3,0) /-0.00001 11066 85196 665D0/
      DATA CK( 4,0) /+0.00000 06325 75108 500D0/
      DATA CK( 5,0) /-0.00000 00450 47337 641D0/
      DATA CK( 6,0) /+0.00000 00037 92996 456D0/
      DATA CK( 7,0) /-0.00000 00003 64547 179D0/
      DATA CK( 8,0) /+0.00000 00000 39043 756D0/
      DATA CK( 9,0) /-0.00000 00000 04579 936D0/
      DATA CK(10,0) /+0.00000 00000 00580 811D0/
      DATA CK(11,0) /-0.00000 00000 00078 832D0/
      DATA CK(12,0) /+0.00000 00000 00011 360D0/
      DATA CK(13,0) /-0.00000 00000 00001 727D0/
      DATA CK(14,0) /+0.00000 00000 00000 275D0/
      DATA CK(15,0) /-0.00000 00000 00000 046D0/
      DATA CK(16,0) /+0.00000 00000 00000 008D0/

      DATA CK( 0,1) /+1.03595 08587 72358 331D0/
      DATA CK( 1,1) /+0.03546 52912 43331 114D0/
      DATA CK( 2,1) /-0.00046 84750 28166 889D0/
      DATA CK( 3,1) /+0.00001 61850 63810 053D0/
      DATA CK( 4,1) /-0.00000 08451 72048 124D0/
      DATA CK( 5,1) /+0.00000 00571 32218 103D0/
      DATA CK( 6,1) /-0.00000 00046 45554 607D0/
      DATA CK( 7,1) /+0.00000 00004 35417 339D0/
      DATA CK( 8,1) /-0.00000 00000 45757 297D0/
      DATA CK( 9,1) /+0.00000 00000 05288 133D0/
      DATA CK(10,1) /-0.00000 00000 00662 613D0/
      DATA CK(11,1) /+0.00000 00000 00089 048D0/
      DATA CK(12,1) /-0.00000 00000 00012 726D0/
      DATA CK(13,1) /+0.00000 00000 00001 921D0/
      DATA CK(14,1) /-0.00000 00000 00000 305D0/
      DATA CK(15,1) /+0.00000 00000 00000 050D0/
      DATA CK(16,1) /-0.00000 00000 00000 009D0/

      NU=0
      LEX=.FALSE.
      GO TO 6

      ENTRY DEBSI0(X)
      NU=0
      LEX=.TRUE.
      GO TO 6

      ENTRY DBESI1(X)
      NU=1
      LEX=.FALSE.
      GO TO 6

      ENTRY DEBSI1(X)
      NU=1
      LEX=.TRUE.

    6 V=ABS(X)
      IF(V .LT. 8) THEN
       Y=(HF*V)**2
       XL=NU+2
       A0=1
       A1=1+2*Y/((XL+1)*(XL-1))
       A2=1+Y*(4+3*Y/((XL+2)*XL))/((XL+3)*(XL-1))
       B0=1
       B1=1-Y/(XL+1)
       B2=1-Y*(1-Y/(2*(XL+2)))/(XL+3)
       W1=3+XL
       V1=3-XL
       V3=XL-1
       V2=V3+V3
       C=0
       DO 3 N = 3,30
       C0=C
       FN=N
       W1=W1+2
       W2=W1-1
       W3=W2-1
       W4=W3-1
       W5=W4-1
       W6=W5-1
       V1=V1+1
       V2=V2+1
       V3=V3+1
       U1=FN*W4
       E=V3/(U1*W3)
       U2=E*Y
       F1=1+Y*V1/(U1*W1)
       F2=(1+Y*V2/(V3*W2*W5))*U2
       F3=-Y*Y*U2/(W4*W5*W5*W6)
       A=F1*A2+F2*A1+F3*A0
       B=F1*B2+F2*B1+F3*B0
       C=A/B
       IF(ABS(C0-C) .LT. EPS*ABS(C)) GO TO 4
       A0=A1
       A1=A2
       A2=A
       B0=B1
       B1=B2
       B2=B
    3  CONTINUE
    4  H=C
       IF(NU .EQ. 1) H=HF*X*H
       IF(LEX) H=EXP(-V)*H
      ELSE
       R=1/V
       H=16*R-1
       ALFA=H+H
       B1=0
       B2=0
       DO 1 I = 24,0,-1
       B0=CI(I,NU)+ALFA*B1-B2
       B2=B1
    1  B1=B0
       H=SQRT(RPI2*R)*(B0-H*B2)
       IF(NU*X .LT. 0) H=-H
       IF(.NOT.LEX) H=EXP(V)*H
      ENDIF
      GO TO 9

      ENTRY DBESK0(X)
      NU=0
      LEX=.FALSE.
      GO TO 8

      ENTRY DEBSK0(X)
      NU=0
      LEX=.TRUE.
      GO TO 8

      ENTRY DBESK1(X)
      NU=1
      LEX=.FALSE.
      GO TO 8

      ENTRY DEBSK1(X)
      NU=1
      LEX=.TRUE.

    8 IF(X .LE. 0) THEN
       H=0
       WRITE(ERRTXT,101) X
       IF(NU .EQ. 0 .AND. .NOT.LEX) CALL MTLPRT(NAME0 ,'C313.1',ERRTXT)
       IF(NU .EQ. 0 .AND.      LEX) CALL MTLPRT(NAME0E,'C313.1',ERRTXT)
       IF(NU .EQ. 1 .AND. .NOT.LEX) CALL MTLPRT(NAME1 ,'C313.1',ERRTXT)
       IF(NU .EQ. 1 .AND.      LEX) CALL MTLPRT(NAME1E,'C313.1',ERRTXT)
      ELSEIF(X .LT. 1) THEN
       B=HF*X
       BK=-(LOG(B)+CE)
       F=BK
       P=HF
       Q=HF
       C=1
       D=B**2
       BK1=P
       DO 11 N = 1,15
       FN=N
       RFN=1/FN
       P=P*RFN
       Q=Q*RFN
       F=(F+P+Q)*RFN
       C=C*D*RFN
       G=C*(P-FN*F)
       H=C*F
       BK=BK+H
       BK1=BK1+G
       IF(BK1*H+ABS(G)*BK .LE. EPS*BK*BK1) GO TO 12
   11  CONTINUE
   12  H=BK
       IF(NU .EQ. 1) H=BK1/B
       IF(LEX) H=EXP(X)*H
      ELSEIF(X .LE. 5) THEN
       XN=4*NU**2
       A=9-XN
       B=25-XN
       C=768*X**2
       C0=48*X
       A0=1
       A1=(16*X+7+XN)/A
       A2=(C+C0*(XN+23)+XN*(XN+62)+129)/(A*B)
       B0=1
       B1=(16*X+9-XN)/A
       B2=(C+C0*B)/(A*B)+1
       C=0
       DO 24 N = 3,30
       C0=C
       FN=N
       FN2=FN+FN
       FN1=FN2-1
       FN3=FN1/(FN2-3)
       FN4=12*FN**2-(1-XN)
       FN5=16*FN1*X
       RAN=1/((FN2+1)**2-XN)
       F1=FN3*(FN4-20*FN)+FN5
       F2=28*FN-FN4-8+FN5
       F3=FN3*((FN2-5)**2-XN)
       A=(F1*A2+F2*A1+F3*A0)*RAN
       B=(F1*B2+F2*B1+F3*B0)*RAN
       C=A/B
       IF(ABS(C0-C) .LT. EPS*ABS(C)) GO TO 25
       A0=A1
       A1=A2
       A2=A
       B0=B1
       B1=B2
       B2=B
   24  CONTINUE
   25  H=C/SQRT(RPIH*X)
       IF(.NOT.LEX) H=EXP(-X)*H
      ELSE
       R=1/X
       H=10*R-1
       ALFA=H+H
       B1=0
       B2=0
       DO 23 I = 16,0,-1
       B0=CK(I,NU)+ALFA*B1-B2
       B2=B1
   23  B1=B0
       H=SQRT(PIH*R)*(B0-H*B2)
       IF(.NOT.LEX) H=EXP(-X)*H
      ENDIF
    9 CONTINUE
      DBESI0=H
      RETURN
  101 FORMAT(' NON-POSITIVE ARGUMENT X = ',1P,E15.6)
      END
CDECK  ID>, RRIZET. 
      FUNCTION RRIZET(X)
      DOUBLE PRECISION D,DRIZET

      SROUND(D)=D+(D-SNGL(D))
      RRIZET=SROUND(DRIZET(DBLE(X)))
      RETURN
      END
CDECK  ID>, RRIZET64.   
      FUNCTION DRIZET(X)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      CHARACTER*(*) NAME
      PARAMETER(NAME='RRIZET/DRIZET')
C
      DIMENSION P1(0:8),P2(0:8),P3(0:9),P4(0:8)
      DIMENSION Q1(0:8),Q2(0:8),Q3(0:9),Q4(0:8)

      PARAMETER (DELTA = 1D-13)
      PARAMETER (Z1 = 1, HF = Z1/2, TH = Z1/3)
      PARAMETER (PI = 3.14159 26535 89793 24D0)
      PARAMETER (PIH = PI/2, PI2 = 2*PI)

      DATA (P1(J),Q1(J),J=0,8)
     A/ 1.28716 81214 82446 39D+10, 2.57433 62429 64846 24D+10,
     1  1.37539 69320 37025 11D+10, 5.93816 56486 79590 16D+09,
     2  5.10665 59183 64406 10D+09, 9.00633 03732 61233 44D+08,
     3  8.56147 10024 33314 86D+08, 8.04253 66342 83289 89D+07,
     4  7.48361 81243 80232 98D+07, 5.60971 17595 41920 06D+06,
     5  4.86010 65854 61882 51D+06, 2.24743 12028 99137 52D+05,
     6  2.73957 49902 21406 09D+05, 7.57457 89093 41537 56D+03,
     7  4.63171 08431 83427 12D+03,-2.37383 57813 73772 62D+01,
     8  5.78758 10040 96660 66D+01, 1/

      DATA (P2(J),Q2(J),J=0,8)
     A/-6.88197 29321 63489 54D+06,-1.29725 62493 48915 54D+09,
     1  7.48218 91630 53159 72D+06,-9.48715 40757 99078 17D+08,
     2 -2.07584 50481 02110 14D+06,-1.05496 19347 40052 03D+08,
     3  3.55302 55709 62142 95D+05, 4.67774 48821 19930 48D+06,
     4 -4.06706 44955 18548 89D+04, 3.12936 04057 38135 34D+06,
     5  3.19804 86402 71469 11D+03, 4.59581 80383 93050 70D+05,
     6 -1.69820 93703 37228 53D+02, 3.88176 10961 03968 34D+04,
     7  5.61485 84239 42890 48D+00, 1.92561 54483 44914 23D+03,
     8 -8.93888 70592 61549 44D-02, 5.12578 12500 00000 00D+01/

      DATA (P3(J),Q3(J),J=0,9)
     A/ 1.66156 48051 57746 76D-11,-6.99562 63351 91916 55D-10,
     1 -4.68068 82766 06545 29D-09,-1.77757 96189 51492 57D-08,
     2  5.83519 72731 91470 47D-07,-9.82231 82573 40780 36D-07,
     3 -4.17644 01264 31456 02D-05,-2.84927 28275 90964 88D-05,
     4  1.85468 42284 35979 59D-03,-5.81727 90938 80480 94D-04,
     5 -5.11288 80022 04902 41D-02,-1.15848 74916 97665 86D-02,
     6  8.10450 23175 11003 53D-01,-1.28149 12405 19781 96D-01,
     7 -5.69951 94876 84789 23D+00,-1.11913 05734 90977 09D+00,
     8  0                         ,-7.67928 76160 46288 13D-01,
     9  0                         , 1/

      DATA (P4(J),Q4(J),J=0,8)
     A/ 1.03144 87718 88597 12D-15, 5.93959 41728 84190 50D-11,
     1 -5.12584 61396 46882 41D-13,-6.04755 35907 99918 06D-09,
     2  1.12948 79419 48735 48D-10, 3.64680 20866 83885 63D-07,
     3 -1.44234 66537 31309 52D-08,-1.29456 90556 80118 12D-05,
     4  1.16824 67698 44580 98D-06, 3.20189 49847 02292 50D-04,
     5 -6.14975 16799 03148 06D-05,-5.07801 55709 99940 77D-03,
     6  2.05594 67798 88303 28D-03, 5.49628 90788 15872 66D-02,
     7 -3.99339 42939 46688 69D-02,-3.24517 61115 59724 19D-01,
     8  3.45234 97673 61784 57D-01, 1/

      V=X
      F=1
      IF(X .NE. 0 .AND. X .LT. HF) THEN
       IX=X-DELTA
       IF(ABS(IX-X) .LE. DELTA) THEN
        IF(MOD(-IX,2) .EQ. 0) THEN
         H=0
         GO TO 9
        ELSE
         V=1-X
         F=2*(-Z1)**((1-IX)/2)*DGAMMA(V)/PI2**V
        ENDIF
       ELSE
        V=1-X
        F=2*SIN(PIH*X)*DGAMMA(V)/PI2**V
       ENDIF
      ENDIF
      IF(X .EQ. 0) THEN
       H=-3*HF
      ELSEIF(X .EQ. 1) THEN
       H=0
       CALL MTLPRT(NAME,'C315.1','ZETA(X) HAS POLE AT X = 1')
      ELSEIF(V .LE. 5) THEN
       AP=P1(8)
       AQ=Q1(8)
       DO 1 J = 7,0,-1
       AP=P1(J)+V*AP
    1  AQ=Q1(J)+V*AQ
       H=AP/(AQ*(V-1))-1
      ELSEIF(V .LE. 11) THEN
       T=TH*(V-8)
       ALFA=T+T
       B1=0
       B2=0
       DO 2 J = 8,0,-1
       B0=P2(J)+ALFA*B1-B2
       B2=B1
    2  B1=B0
       H=B0-T*B2
       B1=0
       B2=0
       DO 12 J = 8,0,-1
       B0=Q2(J)+ALFA*B1-B2
       B2=B1
   12  B1=B0
       H=H/(B0-T*B2)
      ELSEIF(V .LE. 25) THEN
       T=1/V
       AP=P3(7)
       DO 3 J = 6,0,-1
    3  AP=P3(J)+T*AP
       AQ=Q3(9)
       DO 13 J = 8,0,-1
   13  AQ=Q3(J)+T*AQ
       H=HF**(V-T*AP/AQ)
      ELSEIF(V .LE. 55) THEN
       T=1/V
       AP=P4(8)
       AQ=Q4(8)
       DO 4 J = 7,0,-1
       AP=P4(J)+T*AP
    4  AQ=Q4(J)+T*AQ
       H=HF**(V-T*AP/AQ)
      ELSEIF(V .LE. 90) THEN
       H=HF**V+TH**V
      ELSE
       H=HF**V
      ENDIF
      IF(X .LT. 1) H=F*(1+H)
    9 DRIZET=H
      RETURN
      END
CDECK  ID>, RPSIPG. 
      FUNCTION RPSIPG(X,K)
      DOUBLE PRECISION
     + D,DPSIPG

      SROUND(D)=D+(D-SNGL(D))
      RPSIPG=SROUND(DPSIPG(DBLE(X),K))
      RETURN
      END
CDECK  ID>, RPSIPG64.   
      FUNCTION DPSIPG(X,K)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      CHARACTER*(*) NAME
      PARAMETER(NAME='RPSIPG/DPSIPG')
C
      DIMENSION B(0:20,6),C(7,6),NB(6),P1(0:7),Q1(0:7),P2(0:4),Q2(0:4)
      DIMENSION SGN(6),SGF(0:6),SGH(6)

      PARAMETER (DELTA = 1D-13)
      PARAMETER (Z1 = 1, HF = Z1/2)
      PARAMETER (PI = 3.14159 26535 89793 24D0)
      PARAMETER (C1 = -PI**2, C2 = 2*PI**3, C3 = 2*PI**4)
      PARAMETER (C4 = -8*PI**5, C5 = -8*PI**6, C6 = 16*PI**7)

      CHARACTER*80 ERRTXT

      DATA NB /16,17,17,18,19,20/
      DATA SGN /-1,1,-1,1,-1,1/, SGF /1,-1,2,-6,24,-120,720/
      DATA SGH /-0.5D0,1,-3,12,-60,360/
      DATA X0 /1.46163 21449 68362 34D0/

      DATA (P1(J),Q1(J),J=0,7)
     A/ 1.35249 99667 72634 64D+4, 6.93891 11753 76344 44D-7,
     1  4.52856 01699 54728 97D+4, 1.97685 74263 04673 64D+4,
     2  4.51351 68469 73666 26D+4, 4.12551 60835 35383 23D+4,
     3  1.85290 11818 58261 02D+4, 2.93902 87119 93268 19D+4,
     4  3.32915 25149 40693 55D+3, 9.08196 66074 85517 03D+3,
     5  2.40680 32474 35720 18D+2, 1.24474 77785 67085 60D+3,
     6  5.15778 92000 13908 47D+0, 6.74291 29516 37859 38D+1,
     7  6.22835 06918 98474 58D-3, 1/

      DATA (P2(J),Q2(J),J=0,4)
     A/-2.72817 57513 15296 78D-15,7.77788 54852 29616 04D+0,
     1 -6.48157 12376 61965 10D-1, 5.46117 73810 32150 70D+1,
     2 -4.48616 54391 80193 58D+0, 8.92920 70048 18613 70D+1,
     3 -7.01677 22776 67586 64D+0, 3.22703 49379 11433 61D+1,
     7 -2.12940 44513 10105 17D+0, 1/

      DATA B( 0,1) / 0.33483 86979 10949 386D0/
      DATA B( 1,1) /-0.05518 74820 48730 095D0/
      DATA B( 2,1) / 0.00451 01907 36011 502D0/
      DATA B( 3,1) /-0.00036 57058 88303 721D0/
      DATA B( 4,1) / 0.00002 94346 27468 223D0/
      DATA B( 5,1) /-0.00000 23527 76815 151D0/
      DATA B( 6,1) / 0.00000 01868 53176 633D0/
      DATA B( 7,1) /-0.00000 00147 50720 184D0/
      DATA B( 8,1) / 0.00000 00011 57993 337D0/
      DATA B( 9,1) /-0.00000 00000 90439 179D0/
      DATA B(10,1) / 0.00000 00000 07029 627D0/
      DATA B(11,1) /-0.00000 00000 00543 989D0/
      DATA B(12,1) / 0.00000 00000 00041 925D0/
      DATA B(13,1) /-0.00000 00000 00003 219D0/
      DATA B(14,1) / 0.00000 00000 00000 246D0/
      DATA B(15,1) /-0.00000 00000 00000 019D0/
      DATA B(16,1) / 0.00000 00000 00000 001D0/

      DATA B( 0,2) /-0.11259 29353 45473 830D0/
      DATA B( 1,2) / 0.03655 70017 42820 941D0/
      DATA B( 2,2) /-0.00443 59424 96027 282D0/
      DATA B( 3,2) / 0.00047 54758 54728 926D0/
      DATA B( 4,2) /-0.00004 74718 36382 632D0/
      DATA B( 5,2) / 0.00000 45218 15237 353D0/
      DATA B( 6,2) /-0.00000 04163 00079 620D0/
      DATA B( 7,2) / 0.00000 00373 38998 165D0/
      DATA B( 8,2) /-0.00000 00032 79914 474D0/
      DATA B( 9,2) / 0.00000 00002 83211 377D0/
      DATA B(10,2) /-0.00000 00000 24104 028D0/
      DATA B(11,2) / 0.00000 00000 02026 297D0/
      DATA B(12,2) /-0.00000 00000 00168 524D0/
      DATA B(13,2) / 0.00000 00000 00013 885D0/
      DATA B(14,2) /-0.00000 00000 00001 135D0/
      DATA B(15,2) / 0.00000 00000 00000 092D0/
      DATA B(16,2) /-0.00000 00000 00000 007D0/
      DATA B(17,2) / 0.00000 00000 00000 001D0/

      DATA B( 0,3) / 0.07601 26046 55110 384D0/
      DATA B( 1,3) /-0.03625 71864 81828 739D0/
      DATA B( 2,3) / 0.00579 72023 38937 002D0/
      DATA B( 3,3) /-0.00076 96465 13610 481D0/
      DATA B( 4,3) / 0.00009 14920 82189 884D0/
      DATA B( 5,3) /-0.00001 00971 31488 364D0/
      DATA B( 6,3) / 0.00000 10557 77442 831D0/
      DATA B( 7,3) /-0.00000 01059 29577 481D0/
      DATA B( 8,3) / 0.00000 00102 85494 201D0/
      DATA B( 9,3) /-0.00000 00009 72314 310D0/
      DATA B(10,3) / 0.00000 00000 89884 635D0/
      DATA B(11,3) /-0.00000 00000 08153 171D0/
      DATA B(12,3) / 0.00000 00000 00727 572D0/
      DATA B(13,3) /-0.00000 00000 00064 010D0/
      DATA B(14,3) / 0.00000 00000 00005 562D0/
      DATA B(15,3) /-0.00000 00000 00000 478D0/
      DATA B(16,3) / 0.00000 00000 00000 041D0/
      DATA B(17,3) /-0.00000 00000 00000 003D0/

      DATA B( 0,4) /-0.07723 47240 56994 793D0/
      DATA B( 1,4) / 0.04786 71634 51599 467D0/
      DATA B( 2,4) /-0.00944 07021 86674 632D0/
      DATA B( 3,4) / 0.00148 95447 40103 448D0/
      DATA B( 4,4) /-0.00020 49440 23348 860D0/
      DATA B( 5,4) / 0.00002 56714 25065 297D0/
      DATA B( 6,4) /-0.00000 30013 93581 584D0/
      DATA B( 7,4) / 0.00000 03327 66437 356D0/
      DATA B( 8,4) /-0.00000 00353 65412 111D0/
      DATA B( 9,4) / 0.00000 00036 30622 927D0/
      DATA B(10,4) /-0.00000 00003 62096 951D0/
      DATA B(11,4) / 0.00000 00000 35237 509D0/
      DATA B(12,4) /-0.00000 00000 03357 440D0/
      DATA B(13,4) / 0.00000 00000 00314 068D0/
      DATA B(14,4) /-0.00000 00000 00028 908D0/
      DATA B(15,4) / 0.00000 00000 00002 623D0/
      DATA B(16,4) /-0.00000 00000 00000 235D0/
      DATA B(17,4) / 0.00000 00000 00000 021D0/
      DATA B(18,4) /-0.00000 00000 00000 002D0/

      DATA B( 0,5) / 0.10493 30344 59278 632D0/
      DATA B( 1,5) /-0.07887 79016 52793 557D0/
      DATA B( 2,5) / 0.01839 74151 12159 397D0/
      DATA B( 3,5) /-0.00335 22841 59396 504D0/
      DATA B( 4,5) / 0.00052 28782 30918 016D0/
      DATA B( 5,5) /-0.00007 31797 85814 740D0/
      DATA B( 6,5) / 0.00000 94497 29612 085D0/
      DATA B( 7,5) /-0.00000 11463 39856 723D0/
      DATA B( 8,5) / 0.00000 01322 69366 108D0/
      DATA B( 9,5) /-0.00000 00146 46669 180D0/
      DATA B(10,5) / 0.00000 00015 66940 742D0/
      DATA B(11,5) /-0.00000 00001 62791 157D0/
      DATA B(12,5) / 0.00000 00000 16490 345D0/
      DATA B(13,5) /-0.00000 00000 01634 028D0/
      DATA B(14,5) / 0.00000 00000 00158 807D0/
      DATA B(15,5) /-0.00000 00000 00015 171D0/
      DATA B(16,5) / 0.00000 00000 00001 427D0/
      DATA B(17,5) /-0.00000 00000 00000 132D0/
      DATA B(18,5) / 0.00000 00000 00000 012D0/
      DATA B(19,5) /-0.00000 00000 00000 001D0/

      DATA B( 0,6) /-0.17861 76221 42502 753D0/
      DATA B( 1,6) / 0.15577 64622 00520 579D0/
      DATA B( 2,6) /-0.04172 36376 73831 277D0/
      DATA B( 3,6) / 0.00859 71413 03245 400D0/
      DATA B( 4,6) /-0.00149 62277 61073 229D0/
      DATA B( 5,6) / 0.00023 10896 08557 137D0/
      DATA B( 6,6) /-0.00003 26320 44778 436D0/
      DATA B( 7,6) / 0.00000 42960 97867 090D0/
      DATA B( 8,6) /-0.00000 05345 28790 204D0/
      DATA B( 9,6) / 0.00000 00634 78151 644D0/
      DATA B(10,6) /-0.00000 00072 48699 714D0/
      DATA B(11,6) / 0.00000 00008 00521 979D0/
      DATA B(12,6) /-0.00000 00000 85888 793D0/
      DATA B(13,6) / 0.00000 00000 08985 442D0/
      DATA B(14,6) /-0.00000 00000 00919 356D0/
      DATA B(15,6) / 0.00000 00000 00092 225D0/
      DATA B(16,6) /-0.00000 00000 00009 090D0/
      DATA B(17,6) / 0.00000 00000 00000 882D0/
      DATA B(18,6) /-0.00000 00000 00000 084D0/
      DATA B(19,6) / 0.00000 00000 00000 008D0/
      DATA B(20,6) /-0.00000 00000 00000 001D0/

      DATA C(1,1) / 1.66666 66666 66666 67D-1/
      DATA C(2,1) /-3.33333 33333 33333 33D-2/
      DATA C(3,1) / 2.38095 23809 52380 95D-2/
      DATA C(4,1) /-3.33333 33333 33333 33D-2/
      DATA C(5,1) / 7.57575 75757 57575 76D-2/
      DATA C(6,1) /-2.53113 55311 35531 14D-1/
      DATA C(7,1) / 1.16666 66666 66666 67D 0/

      DATA C(1,2) / 5.00000 00000 00000 00D-1/
      DATA C(2,2) /-1.66666 66666 66666 67D-1/
      DATA C(3,2) / 1.66666 66666 66666 67D-1/
      DATA C(4,2) /-3.00000 00000 00000 00D-1/
      DATA C(5,2) / 8.33333 33333 33333 33D-1/
      DATA C(6,2) /-3.29047 61904 76190 48D 0/
      DATA C(7,2) / 1.75000 00000 00000 00D 1/

      DATA C(1,3) / 2.00000 00000 00000 00D 0/
      DATA C(2,3) /-1.00000 00000 00000 00D 0/
      DATA C(3,3) / 1.33333 33333 33333 33D 0/
      DATA C(4,3) /-3.00000 00000 00000 00D 0/
      DATA C(5,3) / 1.00000 00000 00000 00D+1/
      DATA C(6,3) /-4.60666 66666 66666 67D+1/
      DATA C(7,3) / 2.80000 00000 00000 00D+2/

      DATA (C(J,4),J=1,7) /10,-7,12,-33,130,-691,4760/
      DATA (C(J,5),J=1,7) /60,-56,120,-396,1820,-11056,85680/
      DATA (C(J,6),J=1,7) /420,-504,1320,-5148,27300,-187952,1627920/

      A=ABS(X)
      V=A
      IX=X-DELTA
      IF(K .LT. 0 .OR. K .GT. 6) THEN
       H=0
       WRITE(ERRTXT,101) K
       CALL MTLPRT(NAME,'C316.1',ERRTXT)
      ELSEIF(ABS(IX-X) .LE. DELTA) THEN
       H=0
       WRITE(ERRTXT,102) X
       CALL MTLPRT(NAME,'C316.2',ERRTXT)
      ELSEIF(K .EQ. 0) THEN
       IF(A .LE. 3) THEN
        S=0
        IF(A .LT. HF) THEN
         S=1/V
         V=V+1
        ENDIF
        AP=P1(7)
        AQ=Q1(7)
        DO 11 I = 6,0,-1
        AP=P1(I)+V*AP
   11   AQ=Q1(I)+V*AQ
        H=(V-X0)*AP/AQ-S
       ELSE
        R=1/V**2
        AP=P2(4)
        AQ=Q2(4)
        DO 12 I = 3,0,-1
        AP=P2(I)+R*AP
   12   AQ=Q2(I)+R*AQ
        H=LOG(V)-HF/V+AP/AQ
       ENDIF
       IF(X .LT. 0) H=H+1/A+PI/TAN(PI*A)
      ELSE
       K1=K+1
       IF(A .LE. 10) THEN
        IF(A .LT. 3) THEN
         S=-1/V**K1
         DO 1 J = 1,2-INT(A)
         V=V+1
    1    S=S-1/V**K1
         V=V+1
        ELSEIF(A .LE. 4) THEN
         S=0
        ELSE
         V=V-1
         S=1/V**K1
         DO 5 J = 1,INT(A)-4
         V=V-1
    5    S=S+1/V**K1
        ENDIF
        H=2*V-7
        ALFA=H+H
        B1=0
        B2=0
        DO 2 J = NB(K),0,-1
        B0=B(J,K)+ALFA*B1-B2
        B2=B1
    2   B1=B0
        H=B0-H*B2+SGF(K)*S
       ELSE
        S=0
        IF(A .LT. 15) THEN
         S=1/V**K1
         DO 3 J = 1,14-INT(A)
         V=V+1
    3    S=S+1/V**K1
         V=V+1
        ENDIF
        R=1/V**2
        P=R*C(7,K)
        DO 4 J = 6,1,-1
    4   P=R*(C(J,K)+P)
        H=((SGF(K-1)-SGN(K)*P)*V-SGH(K))/V**K1-SGF(K)*S
       ENDIF
       IF(X .LT. 0) THEN
        P=PI*A
        IF(K .EQ. 1) THEN
         V=C1/SIN(P)**2
        ELSEIF(K .EQ. 2) THEN
         V=C2*COS(P)/SIN(P)**3
        ELSEIF(K .EQ. 3) THEN
         S=SIN(P)**2
         V=C3*(2*S-3)/S**2
        ELSEIF(K .EQ. 4) THEN
         S=SIN(P)
         V=C4*COS(P)*(S**2-3)/S**5
        ELSEIF(K .EQ. 5) THEN
         S=SIN(P)**2
         V=C5*(15-15*S+2*S**2)/S**3
        ELSEIF(K .EQ. 6) THEN
         S=SIN(P)
         V=C6*COS(P)*(45-30*S**2+2*S**4)/S**7
        ENDIF
        H=SGN(K)*(H+V+SGF(K)/A**K1)
       ENDIF
      ENDIF
      DPSIPG=H
      RETURN
  101 FORMAT('K = ',I5,'  (< 0  OR  > 6)')
  102 FORMAT('ARGUMENT EQUALS NON-POSITIVE INTEGER =',1P,E15.6)
      END
CDECK  ID>, ADIGAM. 
      FUNCTION ADIGAM(RX)
      DOUBLE PRECISION
     +      DDIGAM,DX,X,C(6),ZERO,ONE,HALF,C0,PI,A,V,H,R,P
      CHARACTER NAME*6

      DATA ZERO /0D0/, ONE /1D0/, HALF /0.5D0/, C0 /15D0/

      DATA PI /3.14159 26535 89793 24D0/
      DATA C(1) / 8.33333 33333 33333 33D-2/
      DATA C(2) /-8.33333 33333 33333 33D-3/
      DATA C(3) / 3.96825 39682 53968 25D-3/
      DATA C(4) /-4.16666 66666 66666 67D-3/
      DATA C(5) / 7.57575 75757 57575 76D-3/
      DATA C(6) /-2.10927 96092 79609 28D-2/

      X=RX
      NAME='ADIGAM'
      ADIGAM = ZERO
    9 A=ABS(X)
      IF(-A .EQ. INT(X)) THEN
       WRITE(6,100) NAME,X
       RETURN
      END IF
      V=A
      H=ZERO
      IF(A .LT. C0) THEN
       H=ONE/V
       DO 1 I = 1,14-INT(A)
       V=V+ONE
    1  H=H+ONE/V
       V=V+ONE
      END IF
      R=ONE/V**2
      P=R*C(1)
      DO 2 I = 6,1,-1
    2 P=R*(C(I)+P)
      H=LOG(V)-HALF/V-P-H
      IF(X .LT. ZERO) H=H+ONE/A+PI/TAN(PI*A)
      IF(NAME .EQ. 'DDIGAM') THEN
      GO TO 10
      ELSE
       ADIGAM=SNGL(H+(H-DBLE(SNGL(H))))
      END IF
      RETURN

      ENTRY DDIGAM(DX)
      X=DX
      NAME='DDIGAM'
      DDIGAM = ZERO
      GO TO 9
  10  DDIGAM = H


  100 FORMAT(7X,'***** CERN C317 ',A6,' ... ARGUMENT EQUALS ',
     1          'NON-POSITIVE INTEGER =',E10.1)
      END
CDECK  ID>, ELFUN.  
      SUBROUTINE ELFUN(X,AK2,SN,CN,DN)
      DOUBLE PRECISION
     +   DSN,DCN,DDN,D

      SROUND(D)=D+(D-SNGL(D))
      CALL DELFUN(DBLE(X),DBLE(AK2),DSN,DCN,DDN)
      SN=SROUND(DSN)
      CN=SROUND(DCN)
      DN=SROUND(DDN)
      RETURN
      END
CDECK  ID>, ELFUN64.
      SUBROUTINE DELFUN(U,AK2,SN,CN,DN)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION C(4)

C     Machine-dependent: EPS1=2**-(MB/2), EPS2=2**-(MB+3)
C     Where M = Number of bits in mantissa

      PARAMETER (MB = 64)
      PARAMETER (Z0 = 0, Z1 = 1, Z2 = 2, HF = Z1/2, QU = Z1/4)
      PARAMETER (PI = 3.14159 26535 89793 24D0, PIH = PI/2)
      PARAMETER (EPS1 = Z2**(-MB/2), EPS2 = Z2**(-(MB+3)))

      DATA AM0 /-1D20/

      SAVE AM0,C,A,L,BIGK

      XM=ABS(AK2)
      IF(U .EQ. 0) THEN
       SN=0
       DN=1
       CN=1
      ELSEIF(XM .EQ. 0) THEN
       SN=SIN(U)
       DN=1
       CN=COS(U)
      ELSEIF(XM .EQ. 1) THEN
       SN=TANH(U)
       DN=1/COSH(U)
       CN=DN
      ELSE
       IF(XM .LE. 1) THEN
        U1=U
        AM=XM
       ELSE
        W=SQRT(XM)
        U1=W*U
        AM=1/XM
       ENDIF
       IF(AM .LE. HF) THEN
        IF(AM .EQ. AM0) GO TO 1
        AM0=AM
        C(4)=QU*AM
        B=SQRT(1-AM)
       ELSE
        AMC=1-AM
        IF(AMC .EQ. AM0) GO TO 1
        AM0=AMC
        C(4)=QU*AMC
        B=SQRT(AM)
       ENDIF

C     Gauss arithmetic-geometric mean. Skipped if previous modulus.

       A=1
       L=4
    2  IF(C(L) .GE. EPS1) THEN
        L=L-1
        C(L)=(QU*(A-B))**2
        A1=HF*(A+B)
        B=SQRT(A*B)
        A=A1
        GO TO 2
       ENDIF
       A=HF*(A+B)
       BIGK=PIH/A

C     Descending Landen-Gauss transformation for real argument

    1  IF(AM .LE. HF) THEN
        X=SIN(A*U1)
        IF(X .EQ. 0) THEN
         SN=0
         DN=1
         CN=1
        ELSE
         X=A/X
         DO 3 J = L,4
         X1=C(J)/X
    3    X=X1+X
         H=1/X
         SN=H
         DN=1-2*X1*H
         CN=SIGN(SQRT(ABS(1-H**2)),BIGK-ABS(U1))
        ENDIF
       ELSE

C     Descending Landen-Gauss Transformation for imaginary argument

        Y=A/SINH(A*U1)
        DO 4 J=L,4
        Y1=C(J)/Y
        Y=Y-Y1
    4   IF(Y .EQ. 0) Y=EPS2
        H=1/Y
        Y1=2*Y1*H
        CN=SIGN(SQRT(Y/(H+Y)),Y1)
        DN=CN*(1+Y1)
        SN=CN*H
       ENDIF
       IF(XM .GT. 1) THEN
        SN=SN/W
        H=DN
        DN=CN
        CN=H
       ENDIF
      ENDIF
      RETURN
      END
CDECK  ID>, CELFUN. 
      SUBROUTINE CELFUN(Z,AK2,SN,CN,DN)
      COMPLEX Z,SN,CN,DN
      COMPLEX*16
     +    WSN,WCN,WDN
      DOUBLE PRECISION
     +       D
      DOUBLE PRECISION
     +      GREAL,GIMAG,XARG,YARG
      COMPLEX*16
     +      ZARG,GCONJG,GCMPLX
      GREAL( ZARG)=DREAL( ZARG)
      GIMAG( ZARG)=DIMAG( ZARG)
      GCONJG(ZARG)=DCONJG(ZARG)
      GCMPLX(XARG,YARG)=DCMPLX(XARG,YARG)
      SROUND(D)=D+(D-SNGL(D))
      CALL WELFUN
     1     (DCMPLX(DBLE(REAL(Z)),DBLE(AIMAG(Z))),DBLE(AK2),WSN,WCN,WDN)
      SN=CMPLX(SROUND(DREAL(WSN)),SROUND(DIMAG(WSN)))
      CN=CMPLX(SROUND(DREAL(WCN)),SROUND(DIMAG(WCN)))
      DN=CMPLX(SROUND(DREAL(WDN)),SROUND(DIMAG(WDN)))
      RETURN
      END
CDECK  ID>, CELFUN64.   
      SUBROUTINE WELFUN(W,AK2,SN,CN,DN)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      CHARACTER*(*) NAME
      PARAMETER(NAME='CELFUN/WELFUN')
C
C     Jacobian Elliptic Functions SN(W,M),CN(W,M),DN(W,M) for
C     complex argument  w = u+i*v.
C     Iterates for parameter m = k**2 or mc= 1-m if mc < m to obtain
C     fastest convergence and uses finally Jacobi's
C     imaginary transformation to go back to sn, cn, dn of m.
C
      COMPLEX*16
     +  W,SN,CN,DN,I
      DIMENSION C(4)

C     MACHINE-DEPENDENT: EPS1=2**-(MB/2), EPS2=2**-(MB+3)
C     Where M = Number of bits in mantissa

      PARAMETER (MB = 64)
      PARAMETER (Z0 = 0, Z1 = 1, Z2 = 2, HF = Z1/2, QU = Z1/4)
      PARAMETER (I = (0D0,1D0))
      PARAMETER (PI = 3.14159 26535 89793 24D0, PIH = PI/2)
      PARAMETER (EPS1 = Z2**(-MB/2), EPS2 = Z2**(-(MB+3)))

      CHARACTER*80 ERRTXT


      DATA AM0 /-1D20/

      SAVE AM0,C,A,L,BIGK

      DOUBLE PRECISION
     +      GREAL,GIMAG,XARG,YARG
      COMPLEX*16
     +      ZARG,GCONJG,GCMPLX
      GREAL( ZARG)=DREAL( ZARG)
      GIMAG( ZARG)=DIMAG( ZARG)
      GCONJG(ZARG)=DCONJG(ZARG)
      GCMPLX(XARG,YARG)=DCMPLX(XARG,YARG)

      AM=ABS(AK2)
      IF(AM .GT. 1) THEN
       WRITE(ERRTXT,101) AM
       CALL MTLPRT(NAME,'C320.1',ERRTXT)
       RETURN
      ENDIF
      IF(AM .LE. HF) THEN
       U=W
       V=GIMAG(W)
       IF(AM .EQ. AM0) GO TO 1
       XK2=AM
       B=SQRT(1-AM)
      ELSE
       U=GIMAG(W)
       V=-W
       IF(AM .EQ. AM0) GO TO 1
       XK2=1-AM
       B=SQRT(AM)
      ENDIF

      AM0=AM
      A=1
      L=4
      C(L)=QU*XK2

C     Gaussian arithmetic-geometric mean. Skipped if previous M.

    2 IF(C(L) .GE. EPS1) THEN
       L=L-1
       C(L)=(QU*(A-B))**2
       A1=HF*(A+B)
       B=SQRT(A*B)
       A=A1
       GO TO 2
      ENDIF
      A=HF*(A+B)
      BIGK=PIH/A

C     Descending Landen-Gauss Trafo for real U

    1 X=SIN(A*U)
      IF(V .NE. 0 .OR. X .NE. 0) THEN
       IF(X .NE. 0) THEN
        X=A/X
        DO 3 J = L,4
        X1=C(J)/X
   3    X=X1+X
        SU=1/X
        DU=1-2*X1*SU
        CU=SIGN(SQRT(ABS(1-SU**2)),BIGK-ABS(U))
       ENDIF
       IF(V .NE. 0) THEN
        Y=A/SINH(A*V)
        DO 4 J = L,4
        Y1=C(J)/Y
        Y=Y-Y1
        IF(Y .EQ. 0) Y=EPS2
    4   CONTINUE
        SV=1/Y
        Y1=2*Y1*SV
        DV=1+Y1
        CV=SIGN(SQRT((SV+Y)*SV),Y1)

C     Evaluation of complex sn, cn, dn from real and imaginary ones and
C     Jacobi's imaginary argument trafo if necessary

        IF(U .NE. 0) THEN
         SS=-SU*SV
         D=1/(XK2*SS**2+1)
         DV=DV*D
         CU=CU*D
         CC=CU*CV
         DD=DU*DV
         DN=GCMPLX(DD,XK2*SS*CC)
         CN=GCMPLX(CC,SS*DD)
         SN=GCMPLX(SU*CV*DV,SV*CU*DU)
        ELSE
         SN=GCMPLX(Z0,SV)
         CN=CV
         DN=DV
        ENDIF
       ELSE
        SN=SU
        CN=CU
        DN=DU
       ENDIF
       IF(AM .GT. HF) THEN
        CN=1/CN
        DN=DN*CN
        SN=I*SN*CN
       ENDIF
      ELSE
       SN=0
       CN=1
       DN=1
      ENDIF
      RETURN
  101 FORMAT('MODULUS AK2 = ',1P,E15.6,' OUT OF RANGE')
      END
CDECK  ID>, CGPLG.  
      FUNCTION CGPLG(N,M,X)
C
      COMPLEX    CGPLG
      COMPLEX*16
     +   WGPLG,W
      DOUBLE PRECISION
     +   D
      DOUBLE PRECISION
     +      GREAL,GIMAG,XARG,YARG
      COMPLEX*16
     +      ZARG,GCONJG,GCMPLX
      GREAL( ZARG)=DREAL( ZARG)
      GIMAG( ZARG)=DIMAG( ZARG)
      GCONJG(ZARG)=DCONJG(ZARG)
      GCMPLX(XARG,YARG)=DCMPLX(XARG,YARG)
      SROUND(D)=D+(D-SNGL(D))
      W=WGPLG(N,M,DBLE(X))
      CGPLG =CMPLX(SROUND(DREAL(W)),SROUND(DIMAG(W)))
      RETURN
      END
CDECK  ID>, CGPLG64.
      FUNCTION WGPLG(N,M,X)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMPLEX*16
     +   WGPLG
      COMPLEX*16
     +   Z,I,V(0:5),SK,SJ
C
      CHARACTER NAME*(*)
      CHARACTER*80 ERRTXT
      PARAMETER (NAME = 'CGPLG/WGPLG')
      DIMENSION FCT(0:4),SGN(0:4),U(0:4),S1(4,4),C(4,4),A(0:30,10)
      DIMENSION NC(10),INDEX(31)

      PARAMETER (I = (0,1))
      PARAMETER (Z0 = 0, Z1 = 1, HF = Z1/2, C1 = 4*Z1/3, C2 = Z1/3)

      DATA FCT /1,1,2,6,24/, SGN /1,-1,1,-1,1/

      DATA S1(1,1) /1.64493 40668 482D 0/
      DATA S1(1,2) /1.20205 69031 596D 0/
      DATA S1(1,3) /1.08232 32337 111D 0/
      DATA S1(1,4) /1.03692 77551 434D 0/
      DATA S1(2,1) /1.20205 69031 596D 0/
      DATA S1(2,2) /2.70580 80842 778D-1/
      DATA S1(2,3) /9.65511 59989 444D-2/
      DATA S1(3,1) /1.08232 32337 111D 0/
      DATA S1(3,2) /9.65511 59989 444D-2/
      DATA S1(4,1) /1.03692 77551 434D 0/

      DATA C(1,1) / 1.64493 40668 482D0/
      DATA C(1,2) / 1.20205 69031 596D0/
      DATA C(1,3) / 1.08232 32337 111D0/
      DATA C(1,4) / 1.03692 77551 434D0/
      DATA C(2,1) / 0.00000 00000 000D0/
      DATA C(2,2) /-1.89406 56589 945D0/
      DATA C(2,3) /-3.01423 21054 407D0/
      DATA C(3,1) / 1.89406 56589 945D0/
      DATA C(3,2) / 3.01423 21054 407D0/
      DATA C(4,1) / 0.00000 00000 000D0/

      DATA INDEX /1,2,3,4,6*0,5,6,7,7*0,8,9,8*0,10/

      DATA NC /24,26,28,30,22,24,26,19,22,17/

      DATA A( 0,1) / .96753 21504 3498D0/
      DATA A( 1,1) / .16607 30329 2785D0/
      DATA A( 2,1) / .02487 93229 2423D0/
      DATA A( 3,1) / .00468 63619 5945D0/
      DATA A( 4,1) / .00100 16274 9616D0/
      DATA A( 5,1) / .00023 20021 9609D0/
      DATA A( 6,1) / .00005 68178 2272D0/
      DATA A( 7,1) / .00001 44963 0056D0/
      DATA A( 8,1) / .00000 38163 2946D0/
      DATA A( 9,1) / .00000 10299 0426D0/
      DATA A(10,1) / .00000 02835 7538D0/
      DATA A(11,1) / .00000 00793 8705D0/
      DATA A(12,1) / .00000 00225 3670D0/
      DATA A(13,1) / .00000 00064 7434D0/
      DATA A(14,1) / .00000 00018 7912D0/
      DATA A(15,1) / .00000 00005 5029D0/
      DATA A(16,1) / .00000 00001 6242D0/
      DATA A(17,1) / .00000 00000 4827D0/
      DATA A(18,1) / .00000 00000 1444D0/
      DATA A(19,1) / .00000 00000 0434D0/
      DATA A(20,1) / .00000 00000 0131D0/
      DATA A(21,1) / .00000 00000 0040D0/
      DATA A(22,1) / .00000 00000 0012D0/
      DATA A(23,1) / .00000 00000 0004D0/
      DATA A(24,1) / .00000 00000 0001D0/

      DATA A( 0,2) / .95180 88912 7832D0/
      DATA A( 1,2) / .43131 13184 6532D0/
      DATA A( 2,2) / .10002 25071 4905D0/
      DATA A( 3,2) / .02442 41559 5220D0/
      DATA A( 4,2) / .00622 51246 3724D0/
      DATA A( 5,2) / .00164 07883 1235D0/
      DATA A( 6,2) / .00044 40792 0265D0/
      DATA A( 7,2) / .00012 27749 4168D0/
      DATA A( 8,2) / .00003 45398 1284D0/
      DATA A( 9,2) / .00000 98586 9565D0/
      DATA A(10,2) / .00000 28485 6995D0/
      DATA A(11,2) / .00000 08317 0847D0/
      DATA A(12,2) / .00000 02450 3950D0/
      DATA A(13,2) / .00000 00727 6496D0/
      DATA A(14,2) / .00000 00217 5802D0/
      DATA A(15,2) / .00000 00065 4616D0/
      DATA A(16,2) / .00000 00019 8033D0/
      DATA A(17,2) / .00000 00006 0204D0/
      DATA A(18,2) / .00000 00001 8385D0/
      DATA A(19,2) / .00000 00000 5637D0/
      DATA A(20,2) / .00000 00000 1735D0/
      DATA A(21,2) / .00000 00000 0536D0/
      DATA A(22,2) / .00000 00000 0166D0/
      DATA A(23,2) / .00000 00000 0052D0/
      DATA A(24,2) / .00000 00000 0016D0/
      DATA A(25,2) / .00000 00000 0005D0/
      DATA A(26,2) / .00000 00000 0002D0/

      DATA A( 0,3) / .98161 02799 1365D0/
      DATA A( 1,3) / .72926 80632 0726D0/
      DATA A( 2,3) / .22774 71490 9321D0/
      DATA A( 3,3) / .06809 08329 6197D0/
      DATA A( 4,3) / .02013 70118 3064D0/
      DATA A( 5,3) / .00595 47848 0197D0/
      DATA A( 6,3) / .00176 76901 3959D0/
      DATA A( 7,3) / .00052 74821 8502D0/
      DATA A( 8,3) / .00015 82746 1460D0/
      DATA A( 9,3) / .00004 77492 2076D0/
      DATA A(10,3) / .00001 44792 0408D0/
      DATA A(11,3) / .00000 44115 4886D0/
      DATA A(12,3) / .00000 13500 3870D0/
      DATA A(13,3) / .00000 04148 1779D0/
      DATA A(14,3) / .00000 01279 3307D0/
      DATA A(15,3) / .00000 00395 9070D0/
      DATA A(16,3) / .00000 00122 9055D0/
      DATA A(17,3) / .00000 00038 2658D0/
      DATA A(18,3) / .00000 00011 9459D0/
      DATA A(19,3) / .00000 00003 7386D0/
      DATA A(20,3) / .00000 00001 1727D0/
      DATA A(21,3) / .00000 00000 3687D0/
      DATA A(22,3) / .00000 00000 1161D0/
      DATA A(23,3) / .00000 00000 0366D0/
      DATA A(24,3) / .00000 00000 0116D0/
      DATA A(25,3) / .00000 00000 0037D0/
      DATA A(26,3) / .00000 00000 0012D0/
      DATA A(27,3) / .00000 00000 0004D0/
      DATA A(28,3) / .00000 00000 0001D0/

      DATA A( 0,4) /1.06405 21184 614 D0/
      DATA A( 1,4) /1.06917 20744 981 D0/
      DATA A( 2,4) / .41527 19325 1768D0/
      DATA A( 3,4) / .14610 33293 6222D0/
      DATA A( 4,4) / .04904 73264 8784D0/
      DATA A( 5,4) / .01606 34086 0396D0/
      DATA A( 6,4) / .00518 88935 0790D0/
      DATA A( 7,4) / .00166 29871 7324D0/
      DATA A( 8,4) / .00053 05827 9969D0/
      DATA A( 9,4) / .00016 88702 9251D0/
      DATA A(10,4) / .00005 36832 8059D0/
      DATA A(11,4) / .00001 70592 3313D0/
      DATA A(12,4) / .00000 54217 4374D0/
      DATA A(13,4) / .00000 17239 4082D0/
      DATA A(14,4) / .00000 05485 3275D0/
      DATA A(15,4) / .00000 01746 7795D0/
      DATA A(16,4) / .00000 00556 7550D0/
      DATA A(17,4) / .00000 00177 6234D0/
      DATA A(18,4) / .00000 00056 7224D0/
      DATA A(19,4) / .00000 00018 1313D0/
      DATA A(20,4) / .00000 00005 8012D0/
      DATA A(21,4) / .00000 00001 8579D0/
      DATA A(22,4) / .00000 00000 5955D0/
      DATA A(23,4) / .00000 00000 1911D0/
      DATA A(24,4) / .00000 00000 0614D0/
      DATA A(25,4) / .00000 00000 0197D0/
      DATA A(26,4) / .00000 00000 0063D0/
      DATA A(27,4) / .00000 00000 0020D0/
      DATA A(28,4) / .00000 00000 0007D0/
      DATA A(29,4) / .00000 00000 0002D0/
      DATA A(30,4) / .00000 00000 0001D0/

      DATA A( 0,5) / .97920 86066 9175D0/
      DATA A( 1,5) / .08518 81314 8683D0/
      DATA A( 2,5) / .00855 98522 2013D0/
      DATA A( 3,5) / .00121 17721 4413D0/
      DATA A( 4,5) / .00020 72276 8531D0/
      DATA A( 5,5) / .00003 99695 8691D0/
      DATA A( 6,5) / .00000 83806 4065D0/
      DATA A( 7,5) / .00000 18684 8945D0/
      DATA A( 8,5) / .00000 04366 6087D0/
      DATA A( 9,5) / .00000 01059 1733D0/
      DATA A(10,5) / .00000 00264 7892D0/
      DATA A(11,5) / .00000 00067 8700D0/
      DATA A(12,5) / .00000 00017 7654D0/
      DATA A(13,5) / .00000 00004 7342D0/
      DATA A(14,5) / .00000 00001 2812D0/
      DATA A(15,5) / .00000 00000 3514D0/
      DATA A(16,5) / .00000 00000 0975D0/
      DATA A(17,5) / .00000 00000 0274D0/
      DATA A(18,5) / .00000 00000 0077D0/
      DATA A(19,5) / .00000 00000 0022D0/
      DATA A(20,5) / .00000 00000 0006D0/
      DATA A(21,5) / .00000 00000 0002D0/
      DATA A(22,5) / .00000 00000 0001D0/

      DATA A( 0,6) / .95021 85196 3952D0/
      DATA A( 1,6) / .29052 52916 1433D0/
      DATA A( 2,6) / .05081 77406 1716D0/
      DATA A( 3,6) / .00995 54376 7280D0/
      DATA A( 4,6) / .00211 73389 5031D0/
      DATA A( 5,6) / .00047 85947 0550D0/
      DATA A( 6,6) / .00011 33432 1308D0/
      DATA A( 7,6) / .00002 78473 3104D0/
      DATA A( 8,6) / .00000 70478 8108D0/
      DATA A( 9,6) / .00000 18278 8740D0/
      DATA A(10,6) / .00000 04838 7492D0/
      DATA A(11,6) / .00000 01303 3842D0/
      DATA A(12,6) / .00000 00356 3769D0/
      DATA A(13,6) / .00000 00098 7174D0/
      DATA A(14,6) / .00000 00027 6586D0/
      DATA A(15,6) / .00000 00007 8279D0/
      DATA A(16,6) / .00000 00002 2354D0/
      DATA A(17,6) / .00000 00000 6435D0/
      DATA A(18,6) / .00000 00000 1866D0/
      DATA A(19,6) / .00000 00000 0545D0/
      DATA A(20,6) / .00000 00000 0160D0/
      DATA A(21,6) / .00000 00000 0047D0/
      DATA A(22,6) / .00000 00000 0014D0/
      DATA A(23,6) / .00000 00000 0004D0/
      DATA A(24,6) / .00000 00000 0001D0/

      DATA A( 0,7) / .95064 03218 6777D0/
      DATA A( 1,7) / .54138 28546 5171D0/
      DATA A( 2,7) / .13649 97959 0321D0/
      DATA A( 3,7) / .03417 94232 8207D0/
      DATA A( 4,7) / .00869 02788 3583D0/
      DATA A( 5,7) / .00225 28408 4155D0/
      DATA A( 6,7) / .00059 51608 9806D0/
      DATA A( 7,7) / .00015 99561 7766D0/
      DATA A( 8,7) / .00004 36521 3096D0/
      DATA A( 9,7) / .00001 20747 4688D0/
      DATA A(10,7) / .00000 33801 8176D0/
      DATA A(11,7) / .00000 09563 2476D0/
      DATA A(12,7) / .00000 02731 3129D0/
      DATA A(13,7) / .00000 00786 6968D0/
      DATA A(14,7) / .00000 00228 3195D0/
      DATA A(15,7) / .00000 00066 7205D0/
      DATA A(16,7) / .00000 00019 6191D0/
      DATA A(17,7) / .00000 00005 8018D0/
      DATA A(18,7) / .00000 00001 7246D0/
      DATA A(19,7) / .00000 00000 5151D0/
      DATA A(20,7) / .00000 00000 1545D0/
      DATA A(21,7) / .00000 00000 0465D0/
      DATA A(22,7) / .00000 00000 0141D0/
      DATA A(23,7) / .00000 00000 0043D0/
      DATA A(24,7) / .00000 00000 0013D0/
      DATA A(25,7) / .00000 00000 0004D0/
      DATA A(26,7) / .00000 00000 0001D0/

      DATA A( 0,8) / .98800 01167 2229D0/
      DATA A( 1,8) / .04364 06760 9601D0/
      DATA A( 2,8) / .00295 09117 8278D0/
      DATA A( 3,8) / .00031 47780 9720D0/
      DATA A( 4,8) / .00004 31484 6029D0/
      DATA A( 5,8) / .00000 69381 8230D0/
      DATA A( 6,8) / .00000 12464 0350D0/
      DATA A( 7,8) / .00000 02429 3628D0/
      DATA A( 8,8) / .00000 00504 0827D0/
      DATA A( 9,8) / .00000 00109 9075D0/
      DATA A(10,8) / .00000 00024 9467D0/
      DATA A(11,8) / .00000 00005 8540D0/
      DATA A(12,8) / .00000 00001 4127D0/
      DATA A(13,8) / .00000 00000 3492D0/
      DATA A(14,8) / .00000 00000 0881D0/
      DATA A(15,8) / .00000 00000 0226D0/
      DATA A(16,8) / .00000 00000 0059D0/
      DATA A(17,8) / .00000 00000 0016D0/
      DATA A(18,8) / .00000 00000 0004D0/
      DATA A(19,8) / .00000 00000 0001D0/

      DATA A( 0,9) / .95768 50654 6350D0/
      DATA A( 1,9) / .19725 24967 9534D0/
      DATA A( 2,9) / .02603 37031 3918D0/
      DATA A( 3,9) / .00409 38216 8261D0/
      DATA A( 4,9) / .00072 68170 7110D0/
      DATA A( 5,9) / .00014 09187 9261D0/
      DATA A( 6,9) / .00002 92045 8914D0/
      DATA A( 7,9) / .00000 63763 1144D0/
      DATA A( 8,9) / .00000 14516 7850D0/
      DATA A( 9,9) / .00000 03420 5281D0/
      DATA A(10,9) / .00000 00829 4302D0/
      DATA A(11,9) / .00000 00206 0784D0/
      DATA A(12,9) / .00000 00052 2823D0/
      DATA A(13,9) / .00000 00013 5066D0/
      DATA A(14,9) / .00000 00003 5451D0/
      DATA A(15,9) / .00000 00000 9436D0/
      DATA A(16,9) / .00000 00000 2543D0/
      DATA A(17,9) / .00000 00000 0693D0/
      DATA A(18,9) / .00000 00000 0191D0/
      DATA A(19,9) / .00000 00000 0053D0/
      DATA A(20,9) / .00000 00000 0015D0/
      DATA A(21,9) / .00000 00000 0004D0/
      DATA A(22,9) / .00000 00000 0001D0/

      DATA A( 0,10) / .99343 65167 1347D0/
      DATA A( 1,10) / .02225 77012 6826D0/
      DATA A( 2,10) / .00101 47557 4703D0/
      DATA A( 3,10) / .00008 17515 6250D0/
      DATA A( 4,10) / .00000 89997 3547D0/
      DATA A( 5,10) / .00000 12082 3987D0/
      DATA A( 6,10) / .00000 01861 6913D0/
      DATA A( 7,10) / .00000 00317 4723D0/
      DATA A( 8,10) / .00000 00058 5215D0/
      DATA A( 9,10) / .00000 00011 4739D0/
      DATA A(10,10) / .00000 00002 3652D0/
      DATA A(11,10) / .00000 00000 5082D0/
      DATA A(12,10) / .00000 00000 1131D0/
      DATA A(13,10) / .00000 00000 0259D0/
      DATA A(14,10) / .00000 00000 0061D0/
      DATA A(15,10) / .00000 00000 0015D0/
      DATA A(16,10) / .00000 00000 0004D0/
      DATA A(17,10) / .00000 00000 0001D0/

      IF(N .LT. 1 .OR. N .GT. 4 .OR. M .LT. 1 .OR. M .GT. 4 .OR.
     1   N+M .GT. 5) THEN
       Z=0
       WRITE(ERRTXT,101) N,M
       CALL MTLPRT(NAME,'C321.1',ERRTXT)
      ELSEIF(X .EQ. 1) THEN
       Z=S1(N,M)
      ELSEIF(X .GT. 2 .OR. X .LT. -1) THEN
       X1=1/X
       H=C1*X1+C2
       ALFA=H+H
       V(0)=1
       V(1)=LOG(-X+I*Z0)
       DO 33 L = 2,N+M
   33  V(L)=V(1)*V(L-1)/L
       SK=0
       DO 34 K = 0,M-1
       M1=M-K
       R=X1**M1/(FCT(M1)*FCT(N-1))
       SJ=0
       DO 35 J = 0,K
       N1=N+K-J
       L=INDEX(10*N1+M1-10)
       B1=0
       B2=0
       DO 31 IT = NC(L),0,-1
       B0=A(IT,L)+ALFA*B1-B2
       B2=B1
   31  B1=B0
       Q=(FCT(N1-1)/FCT(K-J))*(B0-H*B2)*R/M1**N1
   35  SJ=SJ+V(J)*Q
   34  SK=SK+SGN(K)*SJ
       SJ=0
       DO 36 J = 0,N-1
   36  SJ=SJ+V(J)*C(N-J,M)
       Z=SGN(N)*SK+SGN(M)*(SJ+V(N+M))
      ELSEIF(X .GT. HF) THEN
       X1=1-X
       H=C1*X1+C2
       ALFA=H+H
       V(0)=1
       U(0)=1
       V(1)=LOG(X1+I*Z0)
       U(1)=LOG(X)
       DO 23 L = 2,M
   23  V(L)=V(1)*V(L-1)/L
       DO 26 L = 2,N
   26  U(L)=U(1)*U(L-1)/L
       SK=0
       DO 24 K = 0,N-1
       M1=N-K
       R=X1**M1/FCT(M1)
       SJ=0
       DO 25 J = 0,M-1
       N1=M-J
       L=INDEX(10*N1+M1-10)
       B1=0
       B2=0
       DO 12 IT = NC(L),0,-1
       B0=A(IT,L)+ALFA*B1-B2
       B2=B1
   12  B1=B0
       Q=SGN(J)*(B0-H*B2)*R/M1**N1
   25  SJ=SJ+V(J)*Q
   24  SK=SK+U(K)*(S1(M1,M)-SJ)
       Z=SK+SGN(M)*U(N)*V(M)
      ELSE
       L=INDEX(10*N+M-10)
       H=C1*X+C2
       ALFA=H+H
       B1=0
       B2=0
       DO 11 IT = NC(L),0,-1
       B0=A(IT,L)+ALFA*B1-B2
       B2=B1
   11  B1=B0
       Z=(B0-H*B2)*X**M/(FCT(M)*M**N)
      ENDIF
      WGPLG=Z
      RETURN
  101 FORMAT('ILLEGAL VALUES   N = ',I3,'   M = ',I3)
      END
CDECK  ID>, FRSIN.  
      FUNCTION FRSIN(X)
      DOUBLE PRECISION
     +    DFRSIN,DFRCOS,D

      SROUND(D)=D+(D-SNGL(D))
      FRSIN=SROUND(DFRSIN(DBLE(X)))
      RETURN

      ENTRY FRCOS(X)
      FRCOS=SROUND(DFRCOS(DBLE(X)))
      RETURN
      END
CDECK  ID>, FRSIN64.
      FUNCTION DFRSIN(X)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      DIMENSION A(0:16),B(0:15),C1(0:25),C2(0:28)

      PARAMETER (Z1 = 1, R8 = Z1/8, R32 = Z1/32)

      DATA C0 /1.25331 41373 15500 3D0/

      DATA NA,NB,NC1,NC2 /16,15,25,28/

      DATA A( 0) / 0.76435 13866 41860 002D0/
      DATA A( 1) /-0.43135 54754 76601 793D0/
      DATA A( 2) / 0.43288 19997 97266 531D0/
      DATA A( 3) /-0.26973 31033 83871 110D0/
      DATA A( 4) / 0.08416 04532 08769 354D0/
      DATA A( 5) /-0.01546 52448 44613 820D0/
      DATA A( 6) / 0.00187 85542 34398 220D0/
      DATA A( 7) /-0.00016 26497 76188 875D0/
      DATA A( 8) / 0.00001 05739 76563 833D0/
      DATA A( 9) /-0.00000 05360 93398 892D0/
      DATA A(10) / 0.00000 00218 16584 549D0/
      DATA A(11) /-0.00000 00007 29016 212D0/
      DATA A(12) / 0.00000 00000 20373 325D0/
      DATA A(13) /-0.00000 00000 00483 440D0/
      DATA A(14) / 0.00000 00000 00009 865D0/
      DATA A(15) /-0.00000 00000 00000 175D0/
      DATA A(16) / 0.00000 00000 00000 003D0/

      DATA B( 0) / 0.63041 40431 45705 392D0/
      DATA B( 1) /-0.42344 51140 57053 335D0/
      DATA B( 2) / 0.37617 17264 33436 566D0/
      DATA B( 3) /-0.16249 48915 45095 674D0/
      DATA B( 4) / 0.03822 25577 86330 087D0/
      DATA B( 5) /-0.00564 56347 71321 909D0/
      DATA B( 6) / 0.00057 45495 19768 974D0/
      DATA B( 7) /-0.00004 28707 15321 020D0/
      DATA B( 8) / 0.00000 24512 07499 233D0/
      DATA B( 9) /-0.00000 01109 88418 409D0/
      DATA B(10) / 0.00000 00040 82497 317D0/
      DATA B(11) /-0.00000 00001 24498 302D0/
      DATA B(12) / 0.00000 00000 03200 484D0/
      DATA B(13) /-0.00000 00000 00070 324D0/
      DATA B(14) / 0.00000 00000 00001 336D0/
      DATA B(15) /-0.00000 00000 00000 022D0/

      DATA C1( 0) / 0.99056 04793 73497 549D0/
      DATA C1( 1) /-0.01218 35098 31478 997D0/
      DATA C1( 2) /-0.00248 27428 23113 060D0/
      DATA C1( 3) / 0.00026 60949 52647 247D0/
      DATA C1( 4) /-0.00000 10790 68987 406D0/
      DATA C1( 5) /-0.00000 48836 81753 933D0/
      DATA C1( 6) / 0.00000 09990 55266 368D0/
      DATA C1( 7) /-0.00000 00750 92717 372D0/
      DATA C1( 8) /-0.00000 00190 79487 573D0/
      DATA C1( 9) / 0.00000 00090 90797 293D0/
      DATA C1(10) /-0.00000 00019 66236 033D0/
      DATA C1(11) / 0.00000 00001 64772 911D0/
      DATA C1(12) / 0.00000 00000 63079 714D0/
      DATA C1(13) /-0.00000 00000 36432 219D0/
      DATA C1(14) / 0.00000 00000 10536 930D0/
      DATA C1(15) /-0.00000 00000 01716 438D0/
      DATA C1(16) /-0.00000 00000 00107 124D0/
      DATA C1(17) / 0.00000 00000 00204 099D0/
      DATA C1(18) /-0.00000 00000 00090 064D0/
      DATA C1(19) / 0.00000 00000 00025 506D0/
      DATA C1(20) /-0.00000 00000 00004 036D0/
      DATA C1(21) /-0.00000 00000 00000 570D0/
      DATA C1(22) / 0.00000 00000 00000 762D0/
      DATA C1(23) /-0.00000 00000 00000 363D0/
      DATA C1(24) / 0.00000 00000 00000 118D0/
      DATA C1(25) /-0.00000 00000 00000 025D0/

      DATA C2( 0) / 0.04655 77987 37516 4561D0/
      DATA C2( 1) / 0.04499 21302 01239 4140D0/
      DATA C2( 2) /-0.00175 42871 39651 4532D0/
      DATA C2( 3) /-0.00014 65340 02581 0678D0/
      DATA C2( 4) / 0.00003 91330 40863 0159D0/
      DATA C2( 5) /-0.00000 34932 28659 7731D0/
      DATA C2( 6) /-0.00000 03153 53003 2345D0/
      DATA C2( 7) / 0.00000 01876 58200 8529D0/
      DATA C2( 8) /-0.00000 00377 55280 4930D0/
      DATA C2( 9) / 0.00000 00026 65516 5010D0/
      DATA C2(10) / 0.00000 00010 88144 8122D0/
      DATA C2(11) /-0.00000 00005 35500 7671D0/
      DATA C2(12) / 0.00000 00001 31576 5447D0/
      DATA C2(13) /-0.00000 00000 15286 0881D0/
      DATA C2(14) /-0.00000 00000 03394 7646D0/
      DATA C2(15) / 0.00000 00000 02702 0267D0/
      DATA C2(16) /-0.00000 00000 00946 3142D0/
      DATA C2(17) / 0.00000 00000 00207 1565D0/
      DATA C2(18) /-0.00000 00000 00012 6931D0/
      DATA C2(19) /-0.00000 00000 00013 9756D0/
      DATA C2(20) / 0.00000 00000 00008 5929D0/
      DATA C2(21) /-0.00000 00000 00003 1070D0/
      DATA C2(22) / 0.00000 00000 00000 7515D0/
      DATA C2(23) /-0.00000 00000 00000 0648D0/
      DATA C2(24) /-0.00000 00000 00000 0522D0/
      DATA C2(25) / 0.00000 00000 00000 0386D0/
      DATA C2(26) /-0.00000 00000 00000 0165D0/
      DATA C2(27) / 0.00000 00000 00000 0050D0/
      DATA C2(28) /-0.00000 00000 00000 0009D0/

      V=ABS(X)
      IF(V .LT. 8) THEN
       Y=R8*V
       H=2*Y**2-1
       ALFA=H+H
       B1=0
       B2=0
       DO 4 I = NB,0,-1
       B0=B(I)+ALFA*B1-B2
       B2=B1
    4  B1=B0
       H=SQRT(V)*Y*(B0-B2)
      ELSE
       R=1/V
       H=10*R-1
       ALFA=H+H
       B1=0
       B2=0
       DO 5 I = NC1,0,-1
       B0=C1(I)+ALFA*B1-B2
       B2=B1
    5  B1=B0
       S=B0-H*B2
       B1=0
       B2=0
       DO 6 I = NC2,0,-1
       B0=C2(I)+ALFA*B1-B2
       B2=B1
    6  B1=B0
       H=C0-SQRT(R)*(S*COS(V)+(B0-H*B2)*SIN(V))
      END IF
      IF(X .LT. 0) H=-H
      GO TO 9

      ENTRY DFRCOS(X)
      V=ABS(X)
      IF(V .LT. 8) THEN
       H=R32*V**2-1
       ALFA=H+H
       B1=0
       B2=0
       DO 1 I = NA,0,-1
       B0=A(I)+ALFA*B1-B2
       B2=B1
    1  B1=B0
       H=SQRT(V)*(B0-H*B2)
      ELSE
       R=1/V
       H=10*R-1
       ALFA=H+H
       B1=0
       B2=0
       DO 2 I = NC1,0,-1
       B0=C1(I)+ALFA*B1-B2
       B2=B1
    2  B1=B0
       S=B0-H*B2
       B1=0
       B2=0
       DO 3 I = NC2,0,-1
       B0=C2(I)+ALFA*B1-B2
       B2=B1
    3  B1=B0
       H=C0-SQRT(R)*((B0-H*B2)*COS(V)-S*SIN(V))
      END IF
      IF(X .LT. 0) H=-H
    9 DFRSIN=H
      RETURN
      END
CDECK  ID>, FERFR.  
      FUNCTION FERDR(X,K)
      DOUBLE PRECISION
     +    DFERDR,D

      SROUND(D)=D+(D-SNGL(D))
      FERDR=SROUND(DFERDR(DBLE(X),K))
      RETURN
      END
CDECK  ID>, FERFR64.
      FUNCTION DFERDR(X,K)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      CHARACTER NAME*(*)
      CHARACTER*80 ERRTXT
      PARAMETER (NAME = 'FERDR/DFERDR')

      DIMENSION P1(5),P2(5),P3(5),P4(5),P5(5),P6(5),P7(5),P8(5),P9(5)
      DIMENSION Q1(5),Q2(5),Q3(5),Q4(5),Q5(5),Q6(5),Q7(5),Q8(5),Q9(5)

      DATA C1 /1.77245 38509 05516 03D0/
      DATA C2 /0.88622 69254 52758 01D0/
      DATA C3 /1.32934 03881 79137 02D0/
      DATA C4 /0.66666 66666 66666 67D0/
      DATA C5 /0.40000 00000 00000 00D0/

      DATA P1
     1/-1.25331 41288 20D+0, -1.72366 35577 01D+0, -6.55904 57292 58D-1,
     2 -6.34228 31976 82D-2, -1.48838 31061 16D-5/
      DATA Q1
     1/+1.00000 00000 00D+0, +2.19178 09259 80D+0, +1.60581 29554 06D+0,
     2 +4.44366 95274 81D-1, +3.62423 22881 12D-2/
      DATA P2
     1/-3.13328 53055 70D-1, -4.16187 38522 93D-1, -1.50220 84005 88D-1,
     2 -1.33957 93751 73D-2, -1.51335 07001 38D-5/
      DATA Q2
     1/+1.00000 00000 00D+0, +1.87260 86759 02D+0, +1.14520 44465 78D+0,
     2 +2.57022 55875 73D-1, +1.63990 25435 68D-2/
      DATA P3
     1/-2.34996 39854 06D-1, -2.92737 36375 47D-1, -9.88309 75887 38D-2,
     2 -8.25138 63795 51D-3, -1.87438 41532 23D-5/
      DATA Q3
     1/+1.00000 00000 00D+0, +1.60859 71091 46D+0, +8.27528 95308 80D-1,
     2 +1.52232 23828 50D-1, +7.69512 04750 64D-3/
      DATA P4
     1/+1.07381 27694D+0, +5.60033 03660D+0, +3.68822 11270D+0,
     2 +1.17433 92816D+0, +2.36419 35527D-1/
      DATA Q4
     1/+1.00000 00000D+0, +4.60318 40667D+0, +4.30759 10674D-1,
     2 +4.21511 32145D-1, +1.18326 01601D-2/
      DATA P5
     1/+6.78176 62666 0D-1, +6.33124 01791 0D-1, +2.94479 65177 2D-1,
     2 +8.01320 71141 9D-2, +1.33918 21294 0D-2/
      DATA Q5
     1/+1.00000 00000 0D+0, +1.43740 40039 7D-1, +7.08662 14845 0D-2,
     2 +2.34579 49473 5D-3, -1.29449 92883 5D-5/
      DATA P6
     1/+1.15302 13402D+0, +1.05915 58972D+0, +4.68988 03095D-1,
     2 +1.18829 08784D-1, +1.94387 55787D-2/
      DATA Q6
     1/+1.00000 00000D+0, +3.73489 53841D-2, +2.32484 58137D-2,
     2 -1.37667 70874D-3, +4.64663 92781D-5/
      DATA P7
     1/-8.22255 9330D-1, -3.62036 9345D+1, -3.01538 5410D+3,
     2 -7.04987 1579D+4, -5.69814 5924D+4/
      DATA Q7
     1/+1.00000 0000D+0, +3.93568 9841D+1, +3.56875 6266D+3,
     2 +4.18189 3625D+4, +3.38513 8907D+5/
      DATA P8
     1/+8.22449 97626D-1, +2.00463 03393D+1, +1.82680 93446D+3,
     2 +1.22265 30374D+4, +1.40407 50092D+5/
      DATA Q8
     1/+1.00000 00000D+0, +2.34862 07659D+1, +2.20134 83743D+3,
     1 +1.14426 73596D+4, +1.65847 15900D+5/
      DATA P9
     1/+2.46740 02368 4D+0, +2.19167 58236 8D+2, +1.23829 37907 5D+4,
     2 +2.20667 72496 8D+5, +8.49442 92003 4D+5/
      DATA Q9
     1/+1.00000 00000 0D+0, +8.91125 14061 9D+1, +5.04575 66966 7D+3,
     2 +9.09075 94630 4D+4, +3.89960 91564 1D+5/

      IF(K .EQ. -1) THEN
       IF(X .LE. 1) THEN
        Y=EXP(X)
        H=Y*(C1+Y*
     1       (P1(1)+Y*(P1(2)+Y*(P1(3)+Y*(P1(4)+Y*P1(5)))))/
     2       (Q1(1)+Y*(Q1(2)+Y*(Q1(3)+Y*(Q1(4)+Y*Q1(5))))))
       ELSE IF(X .LE. 4) THEN
        H=(P4(1)+X*(P4(2)+X*(P4(3)+X*(P4(4)+X*P4(5)))))/
     1         (Q4(1)+X*(Q4(2)+X*(Q4(3)+X*(Q4(4)+X*Q4(5)))))
       ELSE
        Y=1/X**2
        H=SQRT(X)*(2+Y*
     1       (P7(1)+Y*(P7(2)+Y*(P7(3)+Y*(P7(4)+Y*P7(5)))))/
     2       (Q7(1)+Y*(Q7(2)+Y*(Q7(3)+Y*(Q7(4)+Y*Q7(5))))))
       END IF
      ELSE IF(K .EQ. 1) THEN
       IF(X .LE. 1) THEN
        Y=EXP(X)
        H=Y*(C2+Y*
     1       (P2(1)+Y*(P2(2)+Y*(P2(3)+Y*(P2(4)+Y*P2(5)))))/
     2       (Q2(1)+Y*(Q2(2)+Y*(Q2(3)+Y*(Q2(4)+Y*Q2(5))))))
       ELSE IF(X .LE. 4) THEN
        H=(P5(1)+X*(P5(2)+X*(P5(3)+X*(P5(4)+X*P5(5)))))/
     1         (Q5(1)+X*(Q5(2)+X*(Q5(3)+X*(Q5(4)+X*Q5(5)))))
       ELSE
        Y=1/X**2
        H=X*SQRT(X)*(C4+Y*
     1       (P8(1)+Y*(P8(2)+Y*(P8(3)+Y*(P8(4)+Y*P8(5)))))/
     2       (Q8(1)+Y*(Q8(2)+Y*(Q8(3)+Y*(Q8(4)+Y*Q8(5))))))
       END IF
      ELSE IF(K .EQ. 3) THEN
       IF(X .LE. 1) THEN
        Y=EXP(X)
        H=Y*(C3+Y*
     1       (P3(1)+Y*(P3(2)+Y*(P3(3)+Y*(P3(4)+Y*P3(5)))))/
     2       (Q3(1)+Y*(Q3(2)+Y*(Q3(3)+Y*(Q3(4)+Y*Q3(5))))))
       ELSE IF(X .LE. 4) THEN
        H=(P6(1)+X*(P6(2)+X*(P6(3)+X*(P6(4)+X*P6(5)))))/
     1         (Q6(1)+X*(Q6(2)+X*(Q6(3)+X*(Q6(4)+X*Q6(5)))))
       ELSE
        Y=1/X**2
        H=X**2*SQRT(X)*(C5+Y*
     1       (P9(1)+Y*(P9(2)+Y*(P9(3)+Y*(P9(4)+Y*P9(5)))))/
     2       (Q9(1)+Y*(Q9(2)+Y*(Q9(3)+Y*(Q9(4)+Y*Q9(5))))))
       END IF
      ELSE
       H=0
       WRITE(ERRTXT,101) K
       CALL MTLPRT(NAME,'C323.1',ERRTXT)
      END IF
      DFERDR=H
      RETURN
  101 FORMAT('INCORRECT K = ',I5)
      END
CDECK  ID>, ATANI.  
      FUNCTION ATANI(X)
      DOUBLE PRECISION
     +    DATANI,D

      SROUND(D)=D+(D-SNGL(D))
      ATANI=SROUND(DATANI(DBLE(X)))
      RETURN
      END
CDECK  ID>, ATANI64.
      FUNCTION DATANI(X)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION C(0:18)

      PARAMETER (PI = 3.14159 26535 89793 24D0, PIH = PI/2)

      DATA C( 0) / 0.93432 00492 92895 95D0/
      DATA C( 1) /-0.01950 47944 34351 90D0/
      DATA C( 2) / 0.00125 17037 06300 59D0/
      DATA C( 3) /-0.00011 19241 41205 64D0/
      DATA C( 4) / 0.00001 17754 53855 07D0/
      DATA C( 5) /-0.00000 13652 83304 87D0/
      DATA C( 6) / 0.00000 01688 82892 74D0/
      DATA C( 7) /-0.00000 00218 80246 51D0/
      DATA C( 8) / 0.00000 00029 35063 61D0/
      DATA C( 9) /-0.00000 00004 04523 41D0/
      DATA C(10) / 0.00000 00000 56976 00D0/
      DATA C(11) /-0.00000 00000 08168 83D0/
      DATA C(12) / 0.00000 00000 01188 69D0/
      DATA C(13) /-0.00000 00000 00175 16D0/
      DATA C(14) / 0.00000 00000 00026 09D0/
      DATA C(15) /-0.00000 00000 00003 92D0/
      DATA C(16) / 0.00000 00000 00000 59D0/
      DATA C(17) /-0.00000 00000 00000 09D0/
      DATA C(18) / 0.00000 00000 00000 01D0/

      V=ABS(X)
      IF(V .LE. 1) THEN
       R=0
       Y=V
      ELSE
       R=PIH*LOG(V)
       Y=1/V
      END IF
      H=2*Y**2-1
      ALFA=H+H
      B1=0
      B2=0
      DO 1 I = 18,0,-1
      B0=C(I)+ALFA*B1-B2
      B2=B1
    1 B1=B0
      R=R+Y*(B0-B2)
      IF(X .LT. 0) R=-R
      DATANI=R
      RETURN
      END
CDECK  ID>, C327.   
C                  of Order 1/4, 1/2 and 3/4
CDECK  ID>, BSIR4.  
      FUNCTION BSIR4(X,NU)
      IMPLICIT DOUBLE PRECISION (D)

      SROUND(D)=D+(D-SNGL(D))
      BSIR4=SROUND(DBSIR4(DBLE(X),NU))
      RETURN

      ENTRY BSKR4(X,NU)
      BSKR4=SROUND(DBSKR4(DBLE(X),NU))
      RETURN

      ENTRY EBSIR4(X,NU)
      EBSIR4=SROUND(DEBIR4(DBLE(X),NU))
      RETURN

      ENTRY EBSKR4(X,NU)
      EBSKR4=SROUND(DEBKR4(DBLE(X),NU))
      RETURN
      END
CDECK  ID>, BSIR464.
      FUNCTION DBSIR4(X,NU)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      CHARACTER*80 ERRTXT
      CHARACTER NAMEI*(*),NAMEK*(*),NAMEIE*(*),NAMEKE*(*)
      PARAMETER (NAMEI = 'BSIR4/DBSIR4', NAMEIE = 'EBSIR4/DEBIR4')
      PARAMETER (NAMEK = 'BSKR4/DBSKR4', NAMEKE = 'EBSKR4/DEBKR4')
      LOGICAL LEX

      DIMENSION BC(0:23,2),CC(0:15,2),PP(-3:3),GG(-3:3)

      PARAMETER (EPS = 1D-14)
      PARAMETER (Z1 = 1, HF =Z1/2)
      PARAMETER (PI = 3.14159 26535 89793 24D0)
      PARAMETER (W2 = 1.41421 35623 73095 05D0)
      PARAMETER (G1 = 3.62560 99082 21908 31D0)
      PARAMETER (G3 = 1.22541 67024 65177 65D0)
      PARAMETER (PIH = PI/2, RPIH = 2/PI, RPI = 1/PI, RW2 = 1/W2)
      PARAMETER (C1 = PI/(2*W2))
      PARAMETER (GM = 2*(1/G3-4/G1), GP = (4/G1+1/G3)/2)

      DATA GG(-3) /0.27581 56628 30209 31D0/, PP(-3) /-0.75D0/
      DATA GG(-1) /0.81604 89390 98262 98D0/, PP(-1) /-0.25D0/
      DATA GG( 1) /1.10326 26513 20837 26D0/, PP( 1) / 0.25D0/
      DATA GG( 3) /1.08806 52521 31017 31D0/, PP( 3) / 0.75D0/

      DATA BC( 0,1) / 1.00619 92270 14122 57D0/
      DATA BC( 1,1) / 0.00631 99620 31140 72D0/
      DATA BC( 2,1) / 0.00012 56131 27965 64D0/
      DATA BC( 3,1) / 0.00000 52052 40761 57D0/
      DATA BC( 4,1) / 0.00000 03591 84411 39D0/
      DATA BC( 5,1) / 0.00000 00355 85362 89D0/
      DATA BC( 6,1) / 0.00000 00036 05011 66D0/
      DATA BC( 7,1) /-0.00000 00001 26294 10D0/
      DATA BC( 8,1) /-0.00000 00002 96595 12D0/
      DATA BC( 9,1) /-0.00000 00001 18337 70D0/
      DATA BC(10,1) /-0.00000 00000 21655 68D0/
      DATA BC(11,1) / 0.00000 00000 03032 04D0/
      DATA BC(12,1) / 0.00000 00000 03041 10D0/
      DATA BC(13,1) / 0.00000 00000 00530 77D0/
      DATA BC(14,1) /-0.00000 00000 00204 53D0/
      DATA BC(15,1) /-0.00000 00000 00105 49D0/
      DATA BC(16,1) / 0.00000 00000 00005 50D0/
      DATA BC(17,1) / 0.00000 00000 00014 36D0/
      DATA BC(18,1) / 0.00000 00000 00001 14D0/
      DATA BC(19,1) /-0.00000 00000 00001 87D0/
      DATA BC(20,1) /-0.00000 00000 00000 32D0/
      DATA BC(21,1) / 0.00000 00000 00000 26D0/
      DATA BC(22,1) / 0.00000 00000 00000 06D0/
      DATA BC(23,1) /-0.00000 00000 00000 04D0/

      DATA BC( 0,2) / 0.98980 19115 24008 91D0/
      DATA BC( 1,2) /-0.01035 09365 14827 02D0/
      DATA BC( 2,2) /-0.00015 85263 84973 08D0/
      DATA BC( 3,2) /-0.00000 60527 21962 69D0/
      DATA BC( 4,2) /-0.00000 04158 38597 31D0/
      DATA BC( 5,2) /-0.00000 00487 99346 57D0/
      DATA BC( 6,2) /-0.00000 00089 86835 44D0/
      DATA BC( 7,2) /-0.00000 00019 83283 58D0/
      DATA BC( 8,2) /-0.00000 00003 58969 60D0/
      DATA BC( 9,2) /-0.00000 00000 08766 62D0/
      DATA BC(10,2) / 0.00000 00000 25819 45D0/
      DATA BC(11,2) / 0.00000 00000 09780 24D0/
      DATA BC(12,2) / 0.00000 00000 00565 05D0/
      DATA BC(13,2) /-0.00000 00000 00851 66D0/
      DATA BC(14,2) /-0.00000 00000 00270 25D0/
      DATA BC(15,2) / 0.00000 00000 00040 96D0/
      DATA BC(16,2) / 0.00000 00000 00040 50D0/
      DATA BC(17,2) / 0.00000 00000 00001 11D0/
      DATA BC(18,2) /-0.00000 00000 00005 25D0/
      DATA BC(19,2) /-0.00000 00000 00000 70D0/
      DATA BC(20,2) / 0.00000 00000 00000 70D0/
      DATA BC(21,2) / 0.00000 00000 00000 14D0/
      DATA BC(22,2) /-0.00000 00000 00000 10D0/
      DATA BC(23,2) /-0.00000 00000 00000 02D0/

      DATA CC( 0,1) / 0.99128 81656 75147 07D0/
      DATA CC( 1,1) /-0.00850 62567 20022 24D0/
      DATA CC( 2,1) / 0.00019 70491 57408 35D0/
      DATA CC( 3,1) /-0.00000 80377 10166 54D0/
      DATA CC( 4,1) / 0.00000 04554 01498 43D0/
      DATA CC( 5,1) /-0.00000 00323 27352 82D0/
      DATA CC( 6,1) / 0.00000 00027 16130 28D0/
      DATA CC( 7,1) /-0.00000 00002 60644 07D0/
      DATA CC( 8,1) / 0.00000 00000 27882 69D0/
      DATA CC( 9,1) /-0.00000 00000 03267 69D0/
      DATA CC(10,1) / 0.00000 00000 00414 09D0/
      DATA CC(11,1) /-0.00000 00000 00056 17D0/
      DATA CC(12,1) / 0.00000 00000 00008 09D0/
      DATA CC(13,1) /-0.00000 00000 00001 23D0/
      DATA CC(14,1) / 0.00000 00000 00000 20D0/
      DATA CC(15,1) /-0.00000 00000 00000 03D0/

      DATA CC( 0,2) / 1.01476 24350 64637 87D0/
      DATA CC( 1,2) / 0.01449 34617 87809 66D0/
      DATA CC( 2,2) /-0.00025 87162 07241 80D0/
      DATA CC( 3,2) / 0.00000 96912 18911 49D0/
      DATA CC( 4,2) /-0.00000 05261 29313 99D0/
      DATA CC( 5,2) / 0.00000 00363 96854 29D0/
      DATA CC( 6,2) /-0.00000 00030 05472 76D0/
      DATA CC( 7,2) / 0.00000 00002 84827 80D0/
      DATA CC( 8,2) /-0.00000 00000 30182 91D0/
      DATA CC( 9,2) / 0.00000 00000 03511 10D0/
      DATA CC(10,2) /-0.00000 00000 00442 27D0/
      DATA CC(11,2) / 0.00000 00000 00059 70D0/
      DATA CC(12,2) /-0.00000 00000 00008 56D0/
      DATA CC(13,2) / 0.00000 00000 00001 30D0/
      DATA CC(14,2) /-0.00000 00000 00000 21D0/
      DATA CC(15,2) / 0.00000 00000 00000 03D0/

      LEX=.FALSE.
      GO TO 8

      ENTRY DEBIR4(X,NU)
      LEX=.TRUE.

    8 MU=ABS(NU)
      IF(MU .NE. 1 .AND. MU .NE. 2 .AND. MU .NE. 3 .OR.
     1   NU .LT. 0 .AND. X .LE. 0 .OR. NU .GT. 0 .AND. X .LT. 0) THEN
       S=0
       WRITE(ERRTXT,101) X,NU
       IF(.NOT.LEX) CALL MTLPRT(NAMEI ,'C327.1',ERRTXT)
       IF(     LEX) CALL MTLPRT(NAMEIE,'C327.1',ERRTXT)
      ELSEIF(X .EQ. 0) THEN
       S=0
      ELSEIF(NU .EQ. -2) THEN
       IF(LEX) THEN
        S=HF*(1+EXP(-X-X))/SQRT(PIH*X)
       ELSE
        S=COSH(X)/SQRT(PIH*X)
       ENDIF
      ELSEIF(NU .EQ. 2) THEN
       IF(LEX) THEN
        IF(X .LT. HF) THEN
         S=SINH(X)*EXP(-X)/SQRT(PIH*X)
        ELSE
         S=HF*(1-EXP(-X-X))/SQRT(PIH*X)
        ENDIF
       ELSE
        S=SINH(X)/SQRT(PIH*X)
       ENDIF
      ELSEIF(X .LT. 8) THEN
       Y=(HF*X)**2
       XN=PP(NU)
       XL=XN+2
       A0=1
       A1=1+2*Y/((XL+1)*(XN+1))
       A2=1+Y*(4+3*Y/((XL+2)*(XN+2)))/((XL+3)*(XN+1))
       B0=1
       B1=1-Y/(XL+1)
       B2=1-Y*(1-Y/(2*(XL+2)))/(XL+3)
       T1=3+XL
       V1=3-XL
       V3=XL-1
       V2=V3+V3
       C=0
       DO 33 N = 3,30
       C0=C
       T1=T1+2
       T2=T1-1
       T3=T2-1
       T4=T3-1
       T5=T4-1
       T6=T5-1
       V1=V1+1
       V2=V2+1
       V3=V3+1
       U1=N*T4
       E=V3/(U1*T3)
       U2=E*Y
       F1=1+Y*V1/(U1*T1)
       F2=(1+Y*V2/(V3*T2*T5))*U2
       F3=-Y*Y*U2/(T4*T5*T5*T6)
       A=F1*A2+F2*A1+F3*A0
       B=F1*B2+F2*B1+F3*B0
       C=A/B
       IF(ABS(C0-C) .LT. EPS*ABS(C)) GO TO 34
       A0=A1
       A1=A2
       A2=A
       B0=B1
       B1=B2
       B2=B
   33  CONTINUE
   34  S=GG(NU)*(HF*X)**PP(NU)*C
       IF(LEX) S=EXP(-X)*S
      ELSE
       K=(MU+1)/2
       R=1/X
       W=SQRT(RPI*R)
       H=16*R-1
       ALFA=H+H
       B1=0
       B2=0
       DO 2 I = 23,0,-1
       B0=BC(I,K)+ALFA*B1-B2
       B2=B1
    2  B1=B0
       S=RW2*W*(B0-H*B2)
       IF(.NOT.LEX) S=EXP(X)*S
       T=0
       IF(NU .LT. 0) THEN
        H=10*R-1
        ALFA=H+H
        B1=0
        B2=0
        DO 3 I = 15,0,-1
        B0=CC(I,K)+ALFA*B1-B2
        B2=B1
    3   B1=B0
        R=EXP(-X)
        T=W*R*(B0-H*B2)
        IF(LEX) T=R*T
       ENDIF
       S=S+T
      ENDIF
      GO TO 99

      ENTRY DBSKR4(X,NU)
      LEX=.FALSE.
      GO TO 9

      ENTRY DEBKR4(X,NU)
      LEX=.TRUE.

    9 MU=ABS(NU)
      IF(MU .NE. 1 .AND. MU .NE. 2 .AND. MU .NE. 3 .OR. X .LE. 0) THEN
       S=0
       WRITE(ERRTXT,101) X,NU
       IF(.NOT.LEX) CALL MTLPRT(NAMEK ,'C327.1',ERRTXT)
       IF(     LEX) CALL MTLPRT(NAMEKE,'C327.1',ERRTXT)
      ELSEIF(MU .EQ. 2) THEN
       S=SQRT(PIH/X)
       IF(.NOT.LEX) S=EXP(-X)*S
      ELSEIF(X .LE. 1) THEN
       A0=PP(-1)
       B=HF*X
       D=-LOG(B)
       F=A0*D
       E=EXP(F)
       G=(GM*A0+GP)*E
       BK=C1*(HF*GM*(E+1/E)+GP*D*SINH(F)/F)
       F=BK
       E=A0**2
       P=HF*C1*G
       Q=HF/G
       C=1
       D=B**2
       BK1=P
       DO 11 N = 1,15
       FN=N
       F=(FN*F+P+Q)/(FN**2-E)
       C=C*D/FN
       P=P/(FN-A0)
       Q=Q/(FN+A0)
       G=C*(P-FN*F)
       H=C*F
       BK=BK+H
       BK1=BK1+G
       IF(H*BK1+ABS(G)*BK .LE. EPS*BK*BK1) GO TO 12
   11  CONTINUE
   12  S=BK
       IF(MU .EQ. 3) S=BK1/B
       IF(LEX) S=EXP(X)*S
      ELSEIF(X .LE. 5) THEN
       XN=4*PP(MU)**2
       A=9-XN
       B=25-XN
       C=768*X**2
       C0=48*X
       A0=1
       A1=(16*X+7+XN)/A
       A2=(C+C0*(XN+23)+XN*(XN+62)+129)/(A*B)
       B0=1
       B1=(16*X+9-XN)/A
       B2=(C+C0*B)/(A*B)+1
       C=0
       DO 24 N = 3,30
       C0=C
       FN=N
       FN2=FN+FN
       FN1=FN2-1
       FN3=FN1/(FN2-3)
       FN4=12*FN**2-(1-XN)
       FN5=16*FN1*X
       RAN=1/((FN2+1)**2-XN)
       F1=FN3*(FN4-20*FN)+FN5
       F2=28*FN-FN4-8+FN5
       F3=FN3*((FN2-5)**2-XN)
       A=(F1*A2+F2*A1+F3*A0)*RAN
       B=(F1*B2+F2*B1+F3*B0)*RAN
       C=A/B
       IF(ABS(C0-C) .LT. EPS*ABS(C)) GO TO 25
       A0=A1
       A1=A2
       A2=A
       B0=B1
       B1=B2
       B2=B
   24  CONTINUE
   25  S=C/SQRT(RPIH*X)
       IF(.NOT.LEX) S=EXP(-X)*S
      ELSE
       K=(MU+1)/2
       R=1/X
       Y=5*R
       H=10*R-1
       ALFA=H+H
       B1=0
       B2=0
       DO 13 I = 15,0,-1
       B0=CC(I,K)+ALFA*B1-B2
       B2=B1
   13  B1=B0
       S=SQRT(PIH*R)*(B0-H*B2)
       IF(.NOT.LEX) S=EXP(-X)*S
      ENDIF
   99 DBSIR4=S
      RETURN
  101 FORMAT('INCORRECT ARGUMENT OR INDEX, X = ',1P,E15.6,5X,'NU = ',I5)
      END
CDECK  ID>, C328.   
C                    Complex Indices.
CDECK  ID>, CWHITM. 
      FUNCTION CWHITM(Z,KA,MU)
      COMPLEX CWHITM,Z,KA,MU
      COMPLEX*16
     + WWHITM,WZ,WKA,WMU,W
      DOUBLE PRECISION
     + D
      DOUBLE PRECISION
     +      GREAL,GIMAG,XARG,YARG
      COMPLEX*16
     +      ZARG,GCONJG,GCMPLX
      GREAL( ZARG)=DREAL( ZARG)
      GIMAG( ZARG)=DIMAG( ZARG)
      GCONJG(ZARG)=DCONJG(ZARG)
      GCMPLX(XARG,YARG)=DCMPLX(XARG,YARG)
      SROUND(D)=D+(D-SNGL(D))
      WZ=Z
      WKA=KA
      WMU=MU
      W=WWHITM(WZ,WKA,WMU)
      CWHITM=CMPLX(SROUND(DREAL(W)),SROUND(DIMAG(W)))
      RETURN
      END
CDECK  ID>, CWHITM64.   
      FUNCTION WWHITM(Z,KA,MU)
C     Computes the Whittaker function
C      M ka,mu (z) = exp(z/2) * z**(mu+1/2) * 1F1(mu-ka+1/2;1+2*mu;z)
C     using
C      1F1(a;b;z) = ro**(-la-1) * exp(-i*ro) * F la (et,ro) / C la (et)
C     where  F la (et,ro)  is the regular Coulomb Wave Function,
C            a = 1+la+i*et, b = 2*la+2, z = -2*i*ro,
C     and where
C      C la (et) = 2**la * exp(-pi*et/2 + (ln gamma(1+la+i*et) +
C                  ln gamma(1+la-i*et))/2 - ln gamma(2*la+2))
C     is the Gamow factor (cf. Coulomb Wave Functions)
      IMPLICIT COMPLEX*16 (A-H,I,O-Z)
      COMPLEX*16
     +   KA,LA,MU
C     IMPLICIT COMPLEX*16 (A-H,I,K,L,M,O-Z)
      DOUBLE PRECISION
     +   AI,AR,BI,BR,CI,CR,ZI,ZR, R1,DELTA,DLN2,HF,PI,PIH
      CHARACTER NAME*(*)
      CHARACTER*80 ERRTXT
      PARAMETER (NAME = 'CWHITM/WWHITM')
      DIMENSION F(0:1),G(0:1),FP(0:1),GP(0:1),SG(0:1)

      PARAMETER (DELTA = 1D-13)
      PARAMETER (R1 = 1, HF = R1/2)
      PARAMETER (PI   = 3.14159 26535 89793 238D0, PIH = PI/2)
      PARAMETER (DLN2 = 0.69314 71805 59945 309D0)
      PARAMETER (I = (0,1), IPI = I*PI, IHF= I/2)

      GLOGAM(Q)=WLOGAM(Q)
      A=MU-KA+HF
      B=1+2*MU
      C=MU+KA+HF
      AR=A
      BR=B
      CR=C
      ZR=Z
      AI=-I*A
      BI=-I*B
      CI=-I*C
      ZI=-I*Z
      IF(ZR .LE. 0 .AND. ZI .EQ. 0) THEN
       H=0
       WRITE(ERRTXT,101) ZR
       CALL MTLPRT(NAME,'C328.1',ERRTXT)
      ELSE IF(ABS(BI) .LE. DELTA .AND.
     1        ABS(INT(BR+SIGN(DELTA,BR))+ABS(BR)) .LE .DELTA) THEN
       H=0
       WRITE(ERRTXT,102) (BR-1)/2
       CALL MTLPRT(NAME,'C328.2',ERRTXT)
      ELSE IF(ABS(AI) .LE. DELTA .AND.
     1        ABS(INT(AR+SIGN(DELTA,AR))+ABS(AR)) .LE .DELTA) THEN
       S=1
       Q=1
       N1=AR+SIGN(DELTA,AR)
       DO 1 N = 1,-N1
       Q=Q*((N1+N-1)/(B+(N-1)))*Z/N
    1  S=S+Q
       H=EXP(-HF*Z)*Z**(HF+MU)*S
      ELSE IF(ABS(CI) .LE. DELTA .AND.
     1        ABS(INT(CR+SIGN(DELTA,CR))+ABS(CR)) .LE .DELTA) THEN
       S=1
       Q=1
       N1=CR+SIGN(DELTA,CR)
       DO 2 N = 1,-N1
       Q=-Q*((N1+N-1)/(B+(N-1)))*Z/N
    2  S=S+Q
       H=EXP(HF*Z)*Z**(HF+MU)*S
      ELSE
       ET=I*KA
       RO=IHF*Z
       LA=MU-HF
       Q=GLOGAM(B)-HF*(GLOGAM(A)+GLOGAM(C))+DLN2
       IF(ZR .LE. 0 .AND. ZI .GT. 0) THEN
        ET=-ET
        RO=-RO
        Q=Q+IPI*(MU+HF)
       END IF
       CALL WCLBES(RO,ET,LA,0,F,G,FP,GP,SG,-1,4,JFAIL,0)
       H=EXP(Q+PIH*(ET-(MU+HF)*I))*F(0)
       IF(JFAIL .NE. 0) THEN
        WRITE(ERRTXT,103) JFAIL
        CALL MTLPRT(NAME,'C328.3',ERRTXT)
       ENDIF
      ENDIF
      WWHITM=H
      RETURN
  101 FORMAT('ARGUMENT Z =',1P,D15.8,' ON NEGATIVE REAL AXIS')
  102 FORMAT('M KA,MU (Z) UNDEFINED OR INFINITE FOR M = ',F8.1,
     1       ' NEGATIVE HALF-INTEGER')
  103 FORMAT('SUBROUTINE C309 CCLBES/WCLBES RETURNS IFAIL = ',I4)
      END
CDECK  ID>, ASLGF.  
      SUBROUTINE ASLGF(MODE,X,M,NL,P)
      DIMENSION P(0:*)
      DOUBLE PRECISION
     +     D,DP(0:100)

      SROUND(D)=D+(D-SNGL(D))
      CALL DASLGF(MODE,DBLE(X),M,NL,DP)
      DO 1 N = 0,NL
    1 P(N)=SROUND(DP(N))
      RETURN
      END
CDECK  ID>, ASLGF64.
      SUBROUTINE DASLGF(MODE,X,MS,NL,P)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      CHARACTER NAME*(*)
      CHARACTER*80 ERRTXT
      PARAMETER (NAME = 'ASLGF/DASLGF')
      PARAMETER (ML=33)
      DIMENSION P(0:*),FCT(0:ML)

      PARAMETER (Z1 = 1, HF = Z1/2)

      DATA FCT( 0) /0.100000000000000000D+01/
      DATA FCT( 1) /0.100000000000000000D+01/
      DATA FCT( 2) /0.200000000000000000D+01/
      DATA FCT( 3) /0.600000000000000000D+01/
      DATA FCT( 4) /0.240000000000000000D+02/
      DATA FCT( 5) /0.120000000000000000D+03/
      DATA FCT( 6) /0.720000000000000000D+03/
      DATA FCT( 7) /0.504000000000000000D+04/
      DATA FCT( 8) /0.403200000000000000D+05/
      DATA FCT( 9) /0.362880000000000000D+06/
      DATA FCT(10) /0.362880000000000000D+07/
      DATA FCT(11) /0.399168000000000000D+08/
      DATA FCT(12) /0.479001600000000000D+09/
      DATA FCT(13) /0.622702080000000000D+10/
      DATA FCT(14) /0.871782912000000000D+11/
      DATA FCT(15) /0.130767436800000000D+13/
      DATA FCT(16) /0.209227898880000000D+14/
      DATA FCT(17) /0.355687428096000000D+15/
      DATA FCT(18) /0.640237370572800000D+16/
      DATA FCT(19) /0.121645100408832000D+18/
      DATA FCT(20) /0.243290200817664000D+19/
      DATA FCT(21) /0.510909421717094400D+20/
      DATA FCT(22) /0.112400072777760768D+22/
      DATA FCT(23) /0.258520167388849766D+23/
      DATA FCT(24) /0.620448401733239439D+24/
      DATA FCT(25) /0.155112100433309860D+26/
      DATA FCT(26) /0.403291461126605636D+27/
      DATA FCT(27) /0.108888694504183522D+29/
      DATA FCT(28) /0.304888344611713861D+30/
      DATA FCT(29) /0.884176199373970195D+31/
      DATA FCT(30) /0.265252859812191059D+33/
      DATA FCT(31) /0.822283865417792282D+34/
      DATA FCT(32) /0.263130836933693530D+36/
      DATA FCT(33) /0.868331761881188650D+37/
   10 IF(ABS(X) .GT. 1) THEN
       WRITE(ERRTXT,101) X
       CALL MTLPRT(NAME,'C330.1',ERRTXT)
       RETURN
      ENDIF
      IF(MODE .NE. 1 .AND. MODE .NE. 2) THEN
       WRITE(ERRTXT,102) MODE
       CALL MTLPRT(NAME,'C330.2',ERRTXT)
       RETURN
      ENDIF

      M=ABS(MS)
      IF(M .EQ. 0) THEN
       IF(NL .LT. 0 .OR. NL .GT. 100) THEN
        WRITE(ERRTXT,103) MS,NL
        CALL MTLPRT(NAME,'C330.3',ERRTXT)
        RETURN
       ENDIF
       P(0)=1
       P(1)=X
       DO 1 N = 1,NL-1
    1  P(N+1)=((2*N+1)*X*P(N)-N*P(N-1))/(N+1)
       IF(MODE .EQ. 2) THEN
        DO 2 N = 0,NL
    2   P(N)=SQRT(N+HF)*P(N)
       ENDIF
      ELSE
       IF(NL .LT. 0 .OR. M .GT. 27 .OR. NL .GT. ML-M) THEN
        WRITE(ERRTXT,103) MS,NL
        CALL MTLPRT(NAME,'C330.3',ERRTXT)
        RETURN
       ENDIF
       DO 3 N = 0,M-1
    3  P(N)=0
       P(M)=HF**M*FCT(2*M)/FCT(M)
       DO 4 N = M,NL-1
    4  P(N+1)=((2*N+1)*X*P(N)-(N+M)*P(N-1))/(N-M+1)
       R=SQRT(1-X**2)**M
       DO 5 N = M,NL
    5  P(N)=R*P(N)
       IF(MODE .EQ. 2) THEN
        DO 6 N = M,NL
    6   P(N)=SQRT((N+HF)*(FCT(N-M)/FCT(N+M)))*P(N)
       ELSEIF(MS .LT. 0) THEN
        DO 7 N = M,NL
    7   P(N)=(FCT(N-M)/FCT(N+M))*P(N)
       ENDIF
      ENDIF
      RETURN
  101 FORMAT('INCORRECT ARGUMENT X = ',1P,E15.6)
  102 FORMAT('INCORRECT MODE = ',I5)
  103 FORMAT('INDICES M = ',I5,' OR NL = ',I5,' NOT PERMITTED')
      END
CDECK  ID>, FCONC.  
      FUNCTION FCONC(X,TAU,M)
      DOUBLE PRECISION
     +     DFCONC,D

      SROUND(D)=D+(D-SNGL(D))
      FCONC=SROUND(DFCONC(DBLE(X),DBLE(TAU),M))
      RETURN
      END
CDECK  ID>, FCONC64.
      FUNCTION DFCONC(X,TAU,M)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMPLEX*16
     +           WGAMMA,WLOGAM
C
C     Computes the (real) Conical Function of the first kind
C                 P M (-1/2 + I*TAU) (X)
C     for M = 0 and M = 1. P m nu (x) is the Legendre function of
C     the first kind.
C     Based on K.S. Koelbig, A program for computing the conical
C     functions of the first kind P ... for m = 0 and m = 1,
C     Computer Phys. Comm. 23 (1981) 51-61.
C
      COMPLEX*16
     +     CGM,CLG,CRG,I,A,B,C,TI,R,RR,U(0:3),V(0:3),W(19)
      LOGICAL LM0,LM1,LTA
      CHARACTER NAME*(*)
      CHARACTER*80 ERRTXT
      PARAMETER (NAME = 'FCONC/DFCONC')
      DIMENSION T(7),H(9),S(5),P(11),D(-1:6)


      PARAMETER (PI  = 3.14159 26535 89793 24D+0)
      PARAMETER (RPI = 1.77245 38509 05516 03D+0)
      PARAMETER (I = (0,1))
      PARAMETER (Z1 = 1, HF = Z1/2, TH = 1+HF, C1 = Z1/10, C2 = Z1/5)
      PARAMETER (RPH = 2/PI, RPW = 2/RPI, TW = 20, NMAX = 200)

      DATA EPS /1D-14/

      FEK(ARG)=DELIKC(ARG)
      FEE(ARG)=DELIEC(ARG)
      FJ0(ARG)=DBESJ0(ARG)
      FJ1(ARG)=DBESJ1(ARG)
      FI0(ARG)=DBESI0(ARG)
      FI1(ARG)=DBESI1(ARG)
      CGM(CRG)=WGAMMA(CRG)
      CLG(CRG)=WLOGAM(CRG)
      LM0=M .EQ. 0
      LM1=M .EQ. 1
      IF(X .LE. -1 .OR. TAU .LT. 0 .OR. .NOT.(LM0 .OR. LM1)) THEN
       FC=0
       WRITE(ERRTXT,101) X,TAU,M
       CALL MTLPRT(NAME,'C331.1',ERRTXT)
       GO TO 99
      END IF
      FC=1-M
      IF(X .EQ. 1) GO TO 99

      IF(TAU .EQ. 0) THEN
       IF(X .LT. 1) THEN
        Y=SQRT(HF*(1-X))
        IF(LM0) THEN
         FC=RPH*FEK(Y)
        ELSE
         FC=RPH*(FEE(Y)-HF*(1+X)*FEK(Y))/SQRT(1-X**2)
        END IF
       ELSE
        Y=SQRT((X-1)/(X+1))
        IF(LM0) THEN
         FC=RPH*FEK(Y)/SQRT(HF*(X+1))
        ELSE
         FC=RPH*SQRT(HF/(X-1))*(FEE(Y)-FEK(Y))
        END IF
       END IF
       GO TO 99
      END IF

      TI=I*TAU
      FM=M
      IF(-1 .LT. X .AND. X .LE. 0) GO TO 11
      IF(0  .LT. X .AND. X .LE. C1 .AND. TAU .LE. 17) GO TO 11
      IF(C1 .LT. X .AND. X .LE. C2 .AND. TAU .LE.  5) GO TO 11
      IF(C1 .LT. X .AND. X .LE. C2 .AND. TAU .LE. 17) GO TO 12
      IF(C2 .LT. X .AND. X .LE. TH .AND. TAU .LE. 20) GO TO 12
      IF(TH .LT. X .AND. TAU .LE. MAX(TW,X)) GO TO 13

      IF(X .LT. 1) THEN
       Y=SQRT(1-X**2)
       T(1)=ACOS(X)
       H(1)=TAU*T(1)
       B0=FI0(H(1))
       B1=FI1(H(1))
       Z=-1
      ELSE
       Y=SQRT(X**2-1)
       T(1)=LOG(X+Y)
       H(1)=TAU*T(1)
       B0=FJ0(H(1))
       B1=FJ1(H(1))
       Z=1
      END IF
      H(1)=T(1)*X/Y
      P(1)=1/TAU
      S(1)=1/T(1)
      DO 5 J = 2,7
      T(J)=T(J-1)*T(1)
    5 H(J)=H(J-1)*H(1)
      DO 6 J = 2,11
    6 P(J)=P(J-1)*P(1)
      DO 7 J = 2,5
    7 S(J)=S(J-1)*S(1)
C
      IF(LM0) THEN
       D(-1)=0
       D(0)=1
       D(1)=(H(1)-1)/(8*T(1))
       D(2)=(9*H(2)+6*H(1)-15-Z*8*T(2))/(128*T(2))
       D(3)=5*(15*H(3)+27*H(2)+21*H(1)-63-Z*T(2)*(16*H(1)+24))/
     1  (1024*T(3))
       D(4)=7*(525*H(4)+1500*H(3)+2430*H(2)+1980*H(1)-6435
     1 +192*T(4)-Z*T(2)*(720*H(2)+1600*H(1)+2160))/(32768*T(4))
       D(5)=21*(2835*H(5)+11025*H(4)+24750*H(3)+38610*H(2)
     1  +32175*H(1)-109395+T(4)*(1984*H(1)+4032)
     2  -Z*T(2)*(4800*H(3)+15120*H(2)+26400*H(1)+34320))/
     3  (262144*T(5))
       D(6)=11*(218295*H(6)+1071630*H(5)+3009825*H(4)+6142500*
     1  H(3)+9398025*H(2)+7936110*H(1)-27776385+T(4)*(254016*H(2)
     2  +749952*H(1)+1100736)-Z*T(2)*(441000*H(4)+1814400*H(3)
     3  +4127760*H(2)+6552000*H(1)+8353800+31232*T(4)))/
     4  (4194304*T(6))
      ELSE
       D(-1)=-1
       D(0)=3*(1-H(1))/(8*T(1))
       D(1)=(-15*H(2)+6*H(1)+9+Z*8*T(2))/(128*T(2))
       D(2)=3*(-35*H(3)-15*H(2)+15*H(1)+35+Z*T(2)*(32*H(1)+8))/
     1  (1024*T(3))
       D(3)=(-4725*H(4)-6300*H(3)-3150*H(2)+3780*H(1)+10395
     1   -1216*T(4)+Z*T(2)*(6000*H(2)+5760*H(1)+1680))/(32768*T(4))
       D(4)=7*(-10395*H(5)-23625*H(4)-28350*H(3)-14850*H(2)
     1  +19305*H(1)+57915-T(4)*(6336*H(1)+6080)+Z*T(2)*
     2  (16800*H(3)+30000*H(2)+25920*H(1)+7920))/(262144*T(5))
       D(5)=(-2837835*H(6)-9168390*H(5)-16372125*H(4)-18918900*H(3)
     1  -10135125*H(2)+13783770*H(1)+43648605-T(4)*(3044160*H(2)
     2  +5588352*H(1)+4213440)+Z*T(2)*(5556600*H(4)+14817600*H(3)
     3  +20790000*H(2)+17297280*H(1)+5405400+323072*T(4)))/
     4  (4194304*T(6))
       D(6)=0
      END IF
      S0=D(0)+(-4*D(3)*S(1)+D(4))*P(4)+
     1 (-192*D(5)*S(3)+144*D(6)*S(2))*P(8)
     2 +Z*(-D(2)*P(2)+(-24*D(4)*S(2)+12*D(5)*S(1)-D(6))*P(6)
     3 +(-1920*D(6)*S(4))*P(10))
      S1=D(1)*P(1)+(8*(D(3)*S(2)-D(4)*S(1))+D(5))*P(5)
     1 +(384*D(5)*S(4)-768*D(6)*S(3))*P(9)
     2 +Z*(D(-1)*TAU+(2*D(2)*S(1)-D(3))*P(3)+(48*D(4)*S(3)
     3 -72*D(5)*S(2)+18*D(6)*S(1))*P(7)+(3840*D(6)*S(5))*P(11))
      FC=SQRT(T(1)/Y)*(B0*S0+B1*S1)
      GO TO 99

   11 LTA=TAU .LE. 10
      X1=X**2
      A=HF*((HF-FM)-TI)
      B=HF*((HF-FM)+TI)
      C=HF
      ASSIGN 1 TO JP
      GO TO 20
    1 R1=R
      R1=R1/ABS(CGM(A+HF))**2
      A=HF*((TH-FM)-TI)
      B=HF*((TH-FM)+TI)
      C=TH
      ASSIGN 2 TO JP
      GO TO 20
    2 R2=R
      FC=RPI*(R1-2*X*R2/ABS(CGM(A-HF))**2)
      IF(LM1) FC=2*FC/SQRT(1-X1)
      GO TO 99

   12 LTA=X .GT. 1 .OR. X .LE. 1 .AND. TAU .LE. 5
      X1=HF*(1-X)
      A=(HF+FM)-TI
      B=(HF+FM)+TI
      C=FM+1
      ASSIGN 3 TO JP
      GO TO 20
    3 FC=R
      IF(LM1) FC=SIGN(HF,1-X)*(TAU**2+HF**2)*SQRT(ABS(X**2-1))*FC
      GO TO 99

   13 LTA=.TRUE.
      X1=1/X**2
      A=HF*((HF-FM)-TI)
      B=HF*((TH-FM)-TI)
      C=1-TI
      ASSIGN 4 TO JP
      GO TO 20
    4 R1=EXP((TI-HF)*LOG(X+X)+CLG(1+TI)-CLG((TH-FM)+TI))*
     1        R*((HF-FM)+TI)/TI
      FC=RPW*R1
      IF(LM1) FC=FC/SQRT(1-X1)
      GO TO 99

   20 IF(LTA) THEN
       Y=-X1
       Y2=Y**2
       Y3=Y*Y2
       W(1)=A+1
       W(2)=A+2
       W(3)=B+1
       W(4)=B+2
       W(5)=C+1
       W(6)=C*W(5)
       W(7)=A+B
       W(8)=A*B
       W(9)=(W(8)/C)*Y
       W(10)=W(1)*W(3)
       W(11)=W(2)*W(4)
       W(12)=1+(W(11)/(W(5)+W(5)))*Y
       W(13)=W(7)-6
       W(14)=W(7)+6
       W(15)=2-W(8)
       W(16)=W(15)-W(7)-W(7)

       V(0)=1
       V(1)=1+(W(10)/(C+C))*Y
       V(2)=W(12)+(W(10)*W(11)/(12*W(6)))*Y2
       U(0)=1
       U(1)=V(1)-W(9)
       U(2)=V(2)-W(9)*W(12)+(W(8)*W(10)/(W(6)+W(6)))*Y2

       R=1
       DO 21 N = 3,NMAX
       FN=N
       RR=R
       H(1)=FN-1
       H(2)=FN-2
       H(3)=FN-3
       H(4)=FN+FN
       H(5)=H(4)-3
       H(6)=H(5)+H(5)
       H(7)=4*(H(4)-1)*H(5)
       H(8)=8*H(5)**2*(H(4)-5)
       H(9)=3*FN**2
       W(1)=A+H(1)
       W(2)=A+H(2)
       W(3)=B+H(1)
       W(4)=B+H(2)
       W(5)=C+H(1)
       W(6)=C+H(2)
       W(7)=C+H(3)
       W(8)=H(2)-A
       W(9)=H(2)-B
       W(10)=H(1)-C
       W(11)=W(1)*W(3)
       W(12)=W(5)*W(6)

       W(17)=1+((H(9)+W(13)*FN+W(16))/(H(6)*W(5)))*Y
       W(18)=-((W(11)*W(10)/H(6)+(H(9)-W(14)*FN+W(15))*W(11)*Y/H(7))/
     1          W(12))*Y
       W(19)=(W(2)*W(11)*W(4)*W(8)*W(9)/(H(8)*W(7)*W(12)))*Y3
       V(3)=W(17)*V(2)+W(18)*V(1)+W(19)*V(0)
       U(3)=W(17)*U(2)+W(18)*U(1)+W(19)*U(0)
       R=U(3)/V(3)
       IF(ABS(R-RR) .LT. EPS) GO TO JP, (1,2,3,4)
       DO 22 J = 1,3
       V(J-1)=V(J)
   22  U(J-1)=U(J)
   21  CONTINUE
      ELSE
       W(1)=X1*A*B/C
       R=1+W(1)
       DO 23 N = 1,NMAX
       FN=N
       RR=R
       W(1)=W(1)*X1*(A+FN)*(B+FN)/((C+FN)*(FN+1))
       R=R+W(1)
       IF(ABS(R-RR) .LT. EPS) GO TO JP, (1,2,3,4)
   23  CONTINUE
      END IF
      FC=0
      WRITE(ERRTXT,102) X
      CALL MTLPRT(NAME,'C331.2',ERRTXT)
   99 DFCONC=FC
      RETURN

  101 FORMAT('ILLEGAL ARGUMENT(S)  X = ',D15.8,' TAU = ',D15.8,
     1       ' M = ',I3)
  102 FORMAT('CONVERGENCE PROBLEM FOR HYPERGEOMETRIC FUNCTION, X = ',
     1        D15.8)
      END
CDECK  ID>, DILOG.  
      FUNCTION DILOG(X)
      DOUBLE PRECISION D,DDILOG

      SROUND(D)=D+(D-SNGL(D))
      DILOG=SROUND(DDILOG(DBLE(X)))
      RETURN
      END
CDECK  ID>, DILOG64.
      FUNCTION DDILOG(X)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION C(0:19)

      PARAMETER (Z1 = 1, HF = Z1/2)
      PARAMETER (PI = 3.14159 26535 89793 24D0)
      PARAMETER (PI3 = PI**2/3, PI6 = PI**2/6, PI12 = PI**2/12)

      DATA C( 0) / 0.42996 69356 08136 97D0/
      DATA C( 1) / 0.40975 98753 30771 05D0/
      DATA C( 2) /-0.01858 84366 50145 92D0/
      DATA C( 3) / 0.00145 75108 40622 68D0/
      DATA C( 4) /-0.00014 30418 44423 40D0/
      DATA C( 5) / 0.00001 58841 55418 80D0/
      DATA C( 6) /-0.00000 19078 49593 87D0/
      DATA C( 7) / 0.00000 02419 51808 54D0/
      DATA C( 8) /-0.00000 00319 33412 74D0/
      DATA C( 9) / 0.00000 00043 45450 63D0/
      DATA C(10) /-0.00000 00006 05784 80D0/
      DATA C(11) / 0.00000 00000 86120 98D0/
      DATA C(12) /-0.00000 00000 12443 32D0/
      DATA C(13) / 0.00000 00000 01822 56D0/
      DATA C(14) /-0.00000 00000 00270 07D0/
      DATA C(15) / 0.00000 00000 00040 42D0/
      DATA C(16) /-0.00000 00000 00006 10D0/
      DATA C(17) / 0.00000 00000 00000 93D0/
      DATA C(18) /-0.00000 00000 00000 14D0/
      DATA C(19) /+0.00000 00000 00000 02D0/

      IF(X .EQ. 1) THEN
       H=PI6
      ELSEIF(X .EQ. -1) THEN
       H=-PI12
      ELSE
       T=-X
       IF(T .LE. -2) THEN
        Y=-1/(1+T)
        S=1
        A=-PI3+HF*(LOG(-T)**2-LOG(1+1/T)**2)
       ELSEIF(T .LT. -1) THEN
        Y=-1-T
        S=-1
        A=LOG(-T)
        A=-PI6+A*(A+LOG(1+1/T))
       ELSE IF(T .LE. -HF) THEN
        Y=-(1+T)/T
        S=1
        A=LOG(-T)
        A=-PI6+A*(-HF*A+LOG(1+T))
       ELSE IF(T .LT. 0) THEN
        Y=-T/(1+T)
        S=-1
        A=HF*LOG(1+T)**2
       ELSE IF(T .LE. 1) THEN
        Y=T
        S=1
        A=0
       ELSE
        Y=1/T
        S=-1
        A=PI6+HF*LOG(T)**2
       ENDIF
       H=Y+Y-1
       ALFA=H+H
       B1=0
       B2=0
       DO 1 I = 19,0,-1
       B0=C(I)+ALFA*B1-B2
       B2=B1
    1  B1=B0
       H=-(S*(B0-H*B2)+A)
      ENDIF
      DDILOG=H
      RETURN
      END
CDECK  ID>, GAPNC.  
      FUNCTION GAPNC(A,X)
      DOUBLE PRECISION
     +          DGAPNC,DGAGNC,D

      SROUND(D)=D+(D-SNGL(D))
      GAPNC=SROUND(DGAPNC(DBLE(A),DBLE(X)))
      RETURN

      ENTRY GAGNC(A,X)
      GAGNC=SROUND(DGAGNC(DBLE(A),DBLE(X)))
      RETURN
      END
CDECK  ID>, GAPNC64.
      FUNCTION DGAPNC(A,X)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C     Calculates the incomplete gamma function P(A,X) as defined by
C     GSTAR(A,X) in Ref. 1. Based on
C     1. W. Gautschi, ALGORITHM 542 Incomplete Gamma Functions,
C        ACM Trans. Math. Software 5 (1979) 482-489
C     2. W. Gautschi, A computational procedure for incomplete gamma
C        functions, ACM Trans. Math. Software 5 (1979) 466-481

      CHARACTER NAME*(*)
      CHARACTER*80 ERRTXT
      PARAMETER (NAME = 'GAPNC/DGAPNC')
      PARAMETER (EPS = 5D-14)
      PARAMETER (ALH = -0.69314 71805 59945 31D0)
      PARAMETER (Z1 = 1, HALF = Z1/2, QUAR = Z1/4)
      PARAMETER (C1 = 3*Z1/2, KMAX = 600, EPS1 = EPS/100)

      DIMENSION C(25)

      DATA C( 1) / 0.57721 56649 01532 86D0/
      DATA C( 2) /-0.65587 80715 20253 88D0/
      DATA C( 3) /-0.04200 26350 34095 24D0/
      DATA C( 4) / 0.16653 86113 82291 49D0/
      DATA C( 5) /-0.04219 77345 55544 34D0/
      DATA C( 6) /-0.00962 19715 27876 97D0/
      DATA C( 7) / 0.00721 89432 46663 10D0/
      DATA C( 8) /-0.00116 51675 91859 07D0/
      DATA C( 9) /-0.00021 52416 74114 95D0/
      DATA C(10) / 0.00012 80502 82388 12D0/
      DATA C(11) /-0.00002 01348 54780 79D0/
      DATA C(12) /-0.00000 12504 93482 14D0/
      DATA C(13) / 0.00000 11330 27231 98D0/
      DATA C(14) /-0.00000 02056 33841 70D0/
      DATA C(15) / 0.00000 00061 16095 10D0/
      DATA C(16) / 0.00000 00050 02007 64D0/
      DATA C(17) /-0.00000 00011 81274 57D0/
      DATA C(18) / 0.00000 00001 04342 67D0/
      DATA C(19) / 0.00000 00000 07782 26D0/
      DATA C(20) /-0.00000 00000 03696 81D0/
      DATA C(21) / 0.00000 00000 00510 04D0/
      DATA C(22) /-0.00000 00000 00020 58D0/
      DATA C(23) /-0.00000 00000 00005 35D0/
      DATA C(24) / 0.00000 00000 00001 23D0/
      DATA C(25) /-0.00000 00000 00000 12D0/

      GLGAMA(V)=DLGAMA(V)

      HST=0
      IF(X .LT. 0) THEN
       WRITE(ERRTXT,101) X
       CALL MTLPRT(NAME,'C334.1',ERRTXT)
       GO TO 99
      ELSEIF(X .EQ. 0) THEN
       IF(A .LT. 0) THEN
        WRITE(ERRTXT,102) A
        CALL MTLPRT(NAME,'C334.2',ERRTXT)
       ELSEIF(A .EQ. 0) THEN
        HST=1
       ENDIF
       GO TO 99
      ELSE
       ALX=LOG(X)
      ENDIF
      IF(X .LT. QUAR) THEN
       ALFA=ALH/ALX
      ELSE
       ALFA=X+QUAR
      ENDIF
      MA=HALF-A
      AEPS=A+MA

      IF(MA .GT. 0) THEN
       IF(AEPS .NE. 0) THEN
        SG=(-1)**(MA-1)*SIGN(Z1,A)*SIGN(Z1,AEPS)
        ALGP1=GLGAMA(1+AEPS)-LOG(ABS(AEPS))
        IF(MA .NE. 1) ALGP1=ALGP1+GLGAMA(1-AEPS)-GLGAMA(MA-AEPS)
       ELSE
        SG=0
        ALGP1=0
       ENDIF
      ELSE
       SG=SIGN(Z1,A)
       ALGP1=GLGAMA(1+A)
      ENDIF
      IF(A .GT. ALFA) THEN
       TERM=1
       SUM=1
       DO 1 K = 1,KMAX
       TERM=X*TERM/(A+K)
       SUM=SUM+TERM
       IF(ABS(TERM) .LE. EPS*SUM) GO TO 2
    1  CONTINUE
       GO TO 98
    2  HST=EXP(A*ALX-X+LOG(SUM)-ALGP1)
      ELSEIF(X .GT. C1) THEN
       P=0
       S=1-A
       Q=(X+S)*(X-1-A)
       R=4*(X+S)
       TERM=1
       SUM=1
       RHO=0
       DO 3 K = 2,KMAX
       P=P+S
       Q=Q+R
       R=R+8
       S=S+2
       T=P*(1+RHO)
       RHO=T/(Q-T)
       TERM=RHO*TERM
       SUM=SUM+TERM
       IF(ABS(TERM) .LE. EPS*SUM) GO TO 4
    3  CONTINUE
       GO TO 98
    4  IF(A .LT. 0) THEN
        HST=1
        IF(MA .LT. 0 .OR. AEPS .NE. 0)
     1   HST=1-SG*EXP(LOG(ABS(A)*SUM/(X+1-A))-X+A*ALX-ALGP1)
       ELSEIF(A .EQ. 0) THEN
        HST=1
       ELSE
        HST=1-EXP(A*ALX-X+LOG(A*SUM/(X+1-A))-ALGP1)
       ENDIF
      ELSE
       AE=A
       IF(A .LT. HALF) THEN
        IF(A .LT. -HALF) AE=AEPS
        SUM=C(25)
        DO 12 K = 24,1,-1
   12   SUM=AE*SUM+C(K)
        GA=-SUM/(1+AE*SUM)
        Y=AE*ALX
        IF(ABS(Y) .GE. 1) THEN
         U=GA-(EXP(Y)-1)/AE
        ELSE
         SUM=1
         TERM=1
         DO 7 K = 2,KMAX
         TERM=Y*TERM/K
         SUM=SUM+TERM
         IF(ABS(TERM) .LE. EPS1*SUM) GO TO 8
    7    CONTINUE
         GO TO 98
    8    U=GA-SUM*ALX
        ENDIF
       ELSE
        U=EXP(GLGAMA(A))-X**A/A
       ENDIF
       P=AE*X
       Q=AE+1
       R=AE+3
       TERM=1
       SUM=1
       DO 9 K = 2,KMAX
       P=P+X
       Q=Q+R
       R=R+2
       TERM=-P*TERM/Q
       SUM=SUM+TERM
       IF(ABS(TERM) .LE. EPS1*SUM) GO TO 10
    9  CONTINUE
       GO TO 98
   10  H=U+X**(AE+1)*SUM/(AE+1)
       IF(A .LT. -HALF) THEN
        H=H*EXP(X-AE*ALX)
        DO 13 J = 1,MA
   13   H=(1-X*H)/(J-AE)
        HST=1
        IF(MA .LT. 0 .OR. AEPS .NE. 0)
     1   HST=1-SG*EXP(LOG(ABS(A)*H)-X+A*ALX-ALGP1)
       ELSEIF(A .EQ. 0) THEN
        HST=1
       ELSE
        HST=1-A*H*EXP(-ALGP1)
       ENDIF
      ENDIF
   99 DGAPNC=HST
      RETURN

   98 WRITE(ERRTXT,103) A,X
      CALL MTLPRT(NAME,'C334.3',ERRTXT)
      GO TO 99
  101 FORMAT('ILLEGAL ARGUMENT X = ',1P,D15.8,' < 0')
  102 FORMAT('ILLEGAL ARGUMENTS  A = ',1P,D15.8,' < 0, X = 0')
  103 FORMAT('PROBLEMS WITH CONVERGENCE, A = ',1P,D15.8,' X = ',D15.8)
      END
CDECK  ID>, GAGNC64.
      FUNCTION DGAGNC(A,X)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

C     Calculates the complementary incomplete gamma function G(A,X)
C     as defined in Ref. 1. Based on
C     1. W. Gautschi, ALGORITHM 542 Incomplete Gamma Functions,
C        ACM Trans. Math. Software 5 (1979) 482-489
C     2. W. Gautschi, A computational procedure for incomplete gamma
C        functions, ACM Trans. Math. Software 5 (1979) 466-481

      CHARACTER NAME*(*)
      CHARACTER*80 ERRTXT
      PARAMETER (NAME = 'GAGNC/DGAGNC')

      PARAMETER (EPS = 5D-14)
      PARAMETER (ALH = -0.69314 71805 59945 31D0)
      PARAMETER (Z1 = 1, HALF = Z1/2, QUAR = Z1/4)
      PARAMETER (C1 = 3*Z1/2, KMAX = 600, EPS1 = EPS/100)

      DIMENSION C(25)

      DATA C( 1) / 0.57721 56649 01532 86D0/
      DATA C( 2) /-0.65587 80715 20253 88D0/
      DATA C( 3) /-0.04200 26350 34095 24D0/
      DATA C( 4) / 0.16653 86113 82291 49D0/
      DATA C( 5) /-0.04219 77345 55544 34D0/
      DATA C( 6) /-0.00962 19715 27876 97D0/
      DATA C( 7) / 0.00721 89432 46663 10D0/
      DATA C( 8) /-0.00116 51675 91859 07D0/
      DATA C( 9) /-0.00021 52416 74114 95D0/
      DATA C(10) / 0.00012 80502 82388 12D0/
      DATA C(11) /-0.00002 01348 54780 79D0/
      DATA C(12) /-0.00000 12504 93482 14D0/
      DATA C(13) / 0.00000 11330 27231 98D0/
      DATA C(14) /-0.00000 02056 33841 70D0/
      DATA C(15) / 0.00000 00061 16095 10D0/
      DATA C(16) / 0.00000 00050 02007 64D0/
      DATA C(17) /-0.00000 00011 81274 57D0/
      DATA C(18) / 0.00000 00001 04342 67D0/
      DATA C(19) / 0.00000 00000 07782 26D0/
      DATA C(20) /-0.00000 00000 03696 81D0/
      DATA C(21) / 0.00000 00000 00510 04D0/
      DATA C(22) /-0.00000 00000 00020 58D0/
      DATA C(23) /-0.00000 00000 00005 35D0/
      DATA C(24) / 0.00000 00000 00001 23D0/
      DATA C(25) /-0.00000 00000 00000 12D0/

      GLGAMA(V)=DLGAMA(V)

      H=0
      IF(X .LT. 0) THEN
       WRITE(ERRTXT,101) X
       CALL MTLPRT(NAME,'C334.1',ERRTXT)
       GO TO 99
      ELSEIF(X .EQ. 0) THEN
       IF(A .LT. 0) THEN
        H=-1/A
       ELSEIF(A .EQ. 0) THEN
       CALL MTLPRT(NAME,'C334.2','ILLEGAL ARGUMENTS A = X = 0')
       ELSE
        H=1
       ENDIF
       GO TO 99
      ELSE
       ALX=LOG(X)
      ENDIF
      IF(X .LT. QUAR) THEN
       ALFA=ALH/ALX
      ELSE
       ALFA=X+QUAR
      ENDIF
      MA=HALF-A
      AEPS=A+MA

      IF(MA .GT. 0) THEN
       IF(AEPS .NE. 0) THEN
        ALGP1=GLGAMA(1+AEPS)-LOG(ABS(AEPS))
        IF(MA .NE. 1) ALGP1=ALGP1+GLGAMA(1-AEPS)-GLGAMA(MA-AEPS)
       ELSE
        ALGP1=0
       ENDIF
      ELSE
       ALGP1=GLGAMA(1+A)
      ENDIF
      IF(A .GT. ALFA) THEN
       TERM=1
       SUM=1
       DO 1 K = 1,KMAX
       TERM=X*TERM/(A+K)
       SUM=SUM+TERM
       IF(ABS(TERM) .LE. EPS*SUM) GO TO 2
    1  CONTINUE
       GO TO 98
    2  H=1-EXP(A*ALX-X+LOG(SUM)-ALGP1)
      ELSEIF(X .GT. C1) THEN
       P=0
       S=1-A
       Q=(X+S)*(X-1-A)
       R=4*(X+S)
       TERM=1
       SUM=1
       RHO=0
       DO 3 K = 2,KMAX
       P=P+S
       Q=Q+R
       R=R+8
       S=S+2
       T=P*(1+RHO)
       RHO=T/(Q-T)
       TERM=RHO*TERM
       SUM=SUM+TERM
       IF(ABS(TERM) .LE. EPS*SUM) GO TO 4
    3  CONTINUE
       GO TO 98
    4  IF(A .LE. 0) THEN
        H=SUM/(X+1-A)
       ELSE
        H=EXP(A*ALX-X+LOG(A*SUM/(X+1-A))-ALGP1)
       ENDIF
      ELSE
       AE=A
       IF(A .LT. HALF) THEN
        IF(A .LT. -HALF) AE=AEPS
        SUM=C(25)
        DO 12 K = 24,1,-1
   12   SUM=AE*SUM+C(K)
        GA=-SUM/(1+AE*SUM)
        Y=AE*ALX
        IF(ABS(Y) .GE. 1) THEN
         U=GA-(EXP(Y)-1)/AE
        ELSE
         SUM=1
         TERM=1
         DO 7 K = 2,KMAX
         TERM=Y*TERM/K
         SUM=SUM+TERM
         IF(ABS(TERM) .LE. EPS1*SUM) GO TO 8
    7    CONTINUE
         GO TO 98
    8    U=GA-SUM*ALX
        ENDIF
       ELSE
        U=EXP(GLGAMA(A))-X**A/A
       ENDIF
       P=AE*X
       Q=AE+1
       R=AE+3
       TERM=1
       SUM=1
       DO 9 K = 2,KMAX
       P=P+X
       Q=Q+R
       R=R+2
       TERM=-P*TERM/Q
       SUM=SUM+TERM
       IF(ABS(TERM) .LE. EPS1*SUM) GO TO 10
    9  CONTINUE
       GO TO 98
   10  H=U+SUM*X**(AE+1)/(AE+1)
       IF(A .LT. -HALF) THEN
        H=H*EXP(X-AE*ALX)
        DO 13 J = 1,MA
   13   H=(1-X*H)/(J-AE)
       ELSEIF(A .LE. 0) THEN
        H=H*EXP(X-A*ALX)
       ELSE
        H=A*H*EXP(-ALGP1)
       ENDIF
      ENDIF
   99 DGAGNC=H
      RETURN

   98 WRITE(ERRTXT,103) A,X
      CALL MTLPRT(NAME,'C334.3',ERRTXT)
      GO TO 99
  101 FORMAT('ILLEGAL ARGUMENT  X = ',1P,E15.6,' < 0')
  103 FORMAT('PROBLEMS WITH CONVERGENCE, A = ',1P,E15.8,'  X = ',E15.6)
      END
CDECK  ID>, CWERF.  
      FUNCTION CWERF(Z)
      COMPLEX CWERF,Z
      COMPLEX*16
     +     WWERF,W
      DOUBLE PRECISION
     +     D


      SROUND(D)=D+(D-SNGL(D))
      W=Z
      W=WWERF(W)
      CWERF=CMPLX(SROUND(DREAL(W)),SROUND(DIMAG(W)))
      END
CDECK  ID>, CWERF64.
      FUNCTION WWERF(Z)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMPLEX*16
     +     WWERF
      COMPLEX*16
C    +     Z,ZH,R(37),S,T,V,W,GCMPLX,GCONJG
     +     Z,ZH,R(37),S,T,V,W

      PARAMETER (Z1 = 1, HF = Z1/2, Z10 = 10)
      PARAMETER (C1 = 74/Z10, C2 = 83/Z10, C3 = Z10/32, C4 = 16/Z10)
      PARAMETER (C = 1.12837 91670 95512 57D0, P = (2*C4)**33)

      DOUBLE PRECISION
     +      GREAL,GIMAG,XARG,YARG
      COMPLEX*16
     +      ZARG,GCONJG,GCMPLX
      GREAL( ZARG)=DREAL( ZARG)
      GIMAG( ZARG)=DIMAG( ZARG)
      GCONJG(ZARG)=DCONJG(ZARG)
      GCMPLX(XARG,YARG)=DCMPLX(XARG,YARG)

C     GREAL(W)=DREAL(W)
C     GIMAG(W)=DIMAG(W)
C     GCONJG(W)=DCONJG(W)
C     GCMPLX(X,Y)=DCMPLX(X,Y)

      X=Z
      Y=GIMAG(Z)
      XA=ABS(X)
      YA=ABS(Y)
      IF(YA .LT. C1 .AND. XA .LT. C2) THEN
       ZH=GCMPLX(YA+C4,XA)
       R(37)=0
       DO 1 N = 36,1,-1
       T=ZH+N*GCONJG(R(N+1))
    1  R(N)=HF*T/(GREAL(T)**2+GIMAG(T)**2)
       XL=P
       S=0
       DO 2 N = 33,1,-1
       XL=C3*XL
    2  S=R(N)*(S+XL)
       V=C*S
      ELSE
       ZH=GCMPLX(YA,XA)
       R(1)=0
       DO 3 N = 9,1,-1
       T=ZH+N*GCONJG(R(1))
    3  R(1)=HF*T/(GREAL(T)**2+GIMAG(T)**2)
       V=C*R(1)
      END IF
      IF(YA .EQ. 0) V=GCMPLX(EXP(-XA**2),GIMAG(V))
      IF(Y .LT. 0) THEN
       V=2*EXP(-GCMPLX(XA,YA)**2)-V
       IF(X .GT. 0) V=GCONJG(V)
      ELSE
       IF(X .LT. 0) V=GCONJG(V)
      END IF
      WWERF=V
      RETURN
      END
CDECK  ID>, SININT. 
      FUNCTION SININT(X)
      DOUBLE PRECISION
     +      DSININ,DCOSIN,D

      SROUND(D)=D+(D-SNGL(D))
      SININT=SROUND(DSININ(DBLE(X)))
      RETURN

      ENTRY COSINT(X)
      COSINT=SROUND(DCOSIN(DBLE(X)))
      RETURN
      END
CDECK  ID>, SININT64.   
      FUNCTION DSININ(X)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      CHARACTER NAME*(*)
      CHARACTER*80 ERRTXT
      PARAMETER (NAME = 'COSINT/DCOSIN')
      DIMENSION S(0:15),C(0:15),P(0:28),Q(0:24)

      PARAMETER (Z1 = 1, R8 = Z1/8, R32 = Z1/32)

      PARAMETER (PI = 3.14159 26535 89793 24D0)
      PARAMETER (CE = 0.57721 56649 01532 86D0)
      PARAMETER (PIH = PI/2)

      DATA S( 0) /+1.95222 09759 53071 08D0/
      DATA S( 1) /-0.68840 42321 25715 44D0/
      DATA S( 2) /+0.45518 55132 25584 84D0/
      DATA S( 3) /-0.18045 71236 83877 85D0/
      DATA S( 4) /+0.04104 22133 75859 24D0/
      DATA S( 5) /-0.00595 86169 55588 85D0/
      DATA S( 6) /+0.00060 01427 41414 43D0/
      DATA S( 7) /-0.00004 44708 32910 75D0/
      DATA S( 8) /+0.00000 25300 78230 75D0/
      DATA S( 9) /-0.00000 01141 30759 30D0/
      DATA S(10) /+0.00000 00041 85783 94D0/
      DATA S(11) /-0.00000 00001 27347 06D0/
      DATA S(12) /+0.00000 00000 03267 36D0/
      DATA S(13) /-0.00000 00000 00071 68D0/
      DATA S(14) /+0.00000 00000 00001 36D0/
      DATA S(15) /-0.00000 00000 00000 02D0/

      DATA C( 0) /+1.94054 91464 83554 93D0/
      DATA C( 1) /+0.94134 09132 86521 34D0/
      DATA C( 2) /-0.57984 50342 92992 76D0/
      DATA C( 3) /+0.30915 72011 15927 13D0/
      DATA C( 4) /-0.09161 01792 20771 34D0/
      DATA C( 5) /+0.01644 37407 51546 25D0/
      DATA C( 6) /-0.00197 13091 95216 41D0/
      DATA C( 7) /+0.00016 92538 85083 50D0/
      DATA C( 8) /-0.00001 09393 29573 11D0/
      DATA C( 9) /+0.00000 05522 38574 84D0/
      DATA C(10) /-0.00000 00223 99493 31D0/
      DATA C(11) /+0.00000 00007 46533 25D0/
      DATA C(12) /-0.00000 00000 20818 33D0/
      DATA C(13) /+0.00000 00000 00493 12D0/
      DATA C(14) /-0.00000 00000 00010 05D0/
      DATA C(15) /+0.00000 00000 00000 18D0/

      DATA P( 0) /+0.96074 78397 52035 96D0/
      DATA P( 1) /-0.03711 38962 12398 06D0/
      DATA P( 2) /+0.00194 14398 88991 90D0/
      DATA P( 3) /-0.00017 16598 84251 47D0/
      DATA P( 4) /+0.00002 11263 77532 31D0/
      DATA P( 5) /-0.00000 32716 32567 12D0/
      DATA P( 6) /+0.00000 06006 92116 15D0/
      DATA P( 7) /-0.00000 01258 67944 03D0/
      DATA P( 8) /+0.00000 00293 25634 58D0/
      DATA P( 9) /-0.00000 00074 56959 21D0/
      DATA P(10) /+0.00000 00020 41054 78D0/
      DATA P(11) /-0.00000 00005 95022 30D0/
      DATA P(12) /+0.00000 00001 83229 67D0/
      DATA P(13) /-0.00000 00000 59205 06D0/
      DATA P(14) /+0.00000 00000 19965 17D0/
      DATA P(15) /-0.00000 00000 06995 11D0/
      DATA P(16) /+0.00000 00000 02536 86D0/
      DATA P(17) /-0.00000 00000 00949 29D0/
      DATA P(18) /+0.00000 00000 00365 52D0/
      DATA P(19) /-0.00000 00000 00144 49D0/
      DATA P(20) /+0.00000 00000 00058 51D0/
      DATA P(21) /-0.00000 00000 00024 23D0/
      DATA P(22) /+0.00000 00000 00010 25D0/
      DATA P(23) /-0.00000 00000 00004 42D0/
      DATA P(24) /+0.00000 00000 00001 94D0/
      DATA P(25) /-0.00000 00000 00000 87D0/
      DATA P(26) /+0.00000 00000 00000 39D0/
      DATA P(27) /-0.00000 00000 00000 18D0/
      DATA P(28) /+0.00000 00000 00000 08D0/

      DATA Q( 0) /+0.98604 06569 62382 60D0/
      DATA Q( 1) /-0.01347 17382 08295 21D0/
      DATA Q( 2) /+0.00045 32928 41165 23D0/
      DATA Q( 3) /-0.00003 06728 86516 55D0/
      DATA Q( 4) /+0.00000 31319 91976 01D0/
      DATA Q( 5) /-0.00000 04211 01964 96D0/
      DATA Q( 6) /+0.00000 00690 72448 30D0/
      DATA Q( 7) /-0.00000 00131 83212 90D0/
      DATA Q( 8) /+0.00000 00028 36974 33D0/
      DATA Q( 9) /-0.00000 00006 73292 34D0/
      DATA Q(10) /+0.00000 00001 73396 87D0/
      DATA Q(11) /-0.00000 00000 47869 39D0/
      DATA Q(12) /+0.00000 00000 14032 35D0/
      DATA Q(13) /-0.00000 00000 04334 96D0/
      DATA Q(14) /+0.00000 00000 01402 73D0/
      DATA Q(15) /-0.00000 00000 00473 06D0/
      DATA Q(16) /+0.00000 00000 00165 58D0/
      DATA Q(17) /-0.00000 00000 00059 94D0/
      DATA Q(18) /+0.00000 00000 00022 37D0/
      DATA Q(19) /-0.00000 00000 00008 59D0/
      DATA Q(20) /+0.00000 00000 00003 38D0/
      DATA Q(21) /-0.00000 00000 00001 36D0/
      DATA Q(22) /+0.00000 00000 00000 56D0/
      DATA Q(23) /-0.00000 00000 00000 24D0/
      DATA Q(24) /+0.00000 00000 00000 10D0/

      IF(ABS(X) .LE. 8) THEN
       Y=R8*X
       H=2*Y**2-1
       ALFA=H+H
       B1=0
       B2=0
       DO 1 I = 15,0,-1
       B0=S(I)+ALFA*B1-B2
       B2=B1
    1  B1=B0
       H=Y*(B0-B2)
      ELSE
       R=1/X
       H=128*R**2-1
       ALFA=H+H
       B1=0
       B2=0
       DO 2 I = 28,0,-1
       B0=P(I)+ALFA*B1-B2
       B2=B1
    2  B1=B0
       PP=B0-H*B2
       B1=0
       B2=0
       DO 3 I = 24,0,-1
       B0=Q(I)+ALFA*B1-B2
       B2=B1
    3  B1=B0
       H=SIGN(PIH,X)-R*(R*PP*SIN(X)+(B0-H*B2)*COS(X))
      END IF
      GO TO 9

      ENTRY DCOSIN(X)

      IF(X .EQ. 0) THEN
       H=0
       CALL MTLPRT(NAME,'C336.1','ARGUMENT X = 0')
      ELSEIF(ABS(X) .LE. 8) THEN
       H=R32*X**2-1
       ALFA=H+H
       B1=0
       B2=0
       DO 4 I = 15,0,-1
       B0=C(I)+ALFA*B1-B2
       B2=B1
    4  B1=B0
       H=CE+LOG(ABS(X))-B0+H*B2
      ELSE
       R=1/X
       H=128*R**2-1
       ALFA=H+H
       B1=0
       B2=0
       DO 5 I = 28,0,-1
       B0=P(I)+ALFA*B1-B2
       B2=B1
    5  B1=B0
       PP=B0-H*B2
       B1=0
       B2=0
       DO 6 I = 24,0,-1
       B0=Q(I)+ALFA*B1-B2
       B2=B1
    6  B1=B0
       H=R*((B0-H*B2)*SIN(X)-R*PP*COS(X))
      END IF
    9 DSININ=H
      RETURN
      END
CDECK  ID>, REXPIN. 
      FUNCTION REXPIN(X)
C     IMPLICIT DOUBLE PRECISION (D)
      DOUBLE PRECISION
     +  D,DEXPIN,DEXPIE

      SROUND(D)=D+(D-SNGL(D))

      ENTRY EXPINT(X)

      REXPIN=SROUND(DEXPIN(DBLE(X)))
      RETURN

      ENTRY REXPIE(X)
      REXPIE=SROUND(DEXPIE(DBLE(X)))
      RETURN
      END
CDECK  ID>, REXPIN64.   
      FUNCTION DEXPIN(X)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      LOGICAL LEX
      CHARACTER NAME*(*),NAMEE*(*)
      PARAMETER (NAME = 'REXPIN/DEXPIN', NAMEE = 'REXPIE/DEXPIE')
      DIMENSION P1(5),Q1(5),P2(7),Q2(7),P3(7),Q3(7),P4(8),Q4(8)
      DIMENSION A1(8),B1(8),A2(8),B2(8),A3(8),B3(8)

      PARAMETER (Z1 = 1, R3 = -2*Z1/3, X0 = 0.37250 74107 81366 63D0)
      DATA P1
     1/+4.29312 52343 20972 6D+0, +3.98941 53870 32106 6D+1,
     2 +2.92525 18866 92054 9D+2, +4.25696 82638 59170 3D+2,
     3 -4.34981 43832 95212 0D+2/
      DATA Q1
     1/+1.00000 00000 00000 0D+0, +1.88992 88395 00296 9D+1,
     2 +1.50950 38744 25130 9D+2, +5.68052 52718 98695 5D+2,
     3 +7.53585 64359 84293 2D+2/
      DATA P2
     1/+4.30967 83946 93887 8D-1, +6.90522 52278 44435 7D+0,
     2 +2.30192 55939 13334 6D+1, +2.43784 08879 13167 3D+1,
     3 +9.04161 55694 63286 6D+0, +9.99979 57705 15949 7D-1,
     4 +4.65627 10797 50956 60D-7/
      DATA Q2
     1/+1.03400 13040 48739 8D-1, +3.31909 21359 33016 0D+0,
     2 +2.04494 78501 37941 7D+1, +4.12807 84189 14243 4D+1,
     3 +3.24264 21069 51380 5D+1, +1.00411 64382 90544 8D+1,
     4 +1.00000 00000 00000 0D+0/
      DATA P3
     1/-5.66575 20653 38687 4D+0, -5.45374 15888 31328 7D+2,
     2 -1.29885 68874 64841 0D+3, -8.95927 95777 29368 1D+2,
     3 -2.41055 82709 70148 5D+2, -2.66271 06043 18114 5D+1,
     4 -9.99999 99999 84469 1D-1/
      DATA Q3
     1/+6.31657 48328 08002 3D+2, +2.40401 71322 59089 5D+3,
     2 +2.77761 94950 91629 6D+3, +1.33278 53774 82572 3D+3,
     3 +2.92310 03938 85332 5D+2, +2.86271 06042 21919 0D+1,
     4 +1.00000 00000 00000 0D+0/
      DATA P4
     1/-8.66937 33995 10695 6D+0, -5.49142 26552 10851 5D+2,
     2 -4.21001 61535 70699 3D+3, -2.49301 39345 86475 9D+5,
     3 -1.19623 66934 92468 7D+5, -2.21744 62775 88453 8D+7,
     4 +3.89280 42131 12014 1D+6, -3.91546 07380 90955 5D+8/
      DATA Q4
     1/+3.41718 75000 00000 0D+1, -1.60708 92658 72208 5D+3,
     2 +3.57300 29805 85081 1D+4, -4.83547 43616 21635 1D+5,
     3 +4.28559 62461 17490 4D+6, -2.49033 37574 05403 3D+7,
     4 +8.91925 76757 56121 1D+7, -1.65254 29972 52109 1D+8/
      DATA A1
     1/-2.18086 38152 07237 1D+0, -2.19010 23385 48806 9D+1,
     2 +9.30816 38566 21651 5D+0, +2.50762 81129 35598 3D+1,
     3 -3.31842 53199 72211 2D+1, +6.01217 99083 00804 8D+1,
     4 -4.32531 13287 81345 8D+1, +1.00443 10922 80779 1D+0/
      DATA B1
     1/+0.00000 00000 00000 0D+0, +3.93707 70185 27150 0D+0,
     2 +3.00892 64837 29152 0D+2, -6.25041 16167 18755 4D+0,
     3 +1.00367 43951 67257 7D+3, +1.43256 73812 19376 0D+1,
     4 +2.73624 11988 93280 6D+3, +5.27468 85196 29078 5D-1/
      DATA A2
     1/-3.48334 65360 28526 1D+0, -1.86545 45488 33988 4D+1,
     2 -8.28561 99414 06413 2D+0, -3.23467 33030 54034 6D+1,
     3 +1.79601 68876 92516 4D+1, +1.75656 31546 96144 2D+0,
     4 -1.95022 32128 96598 2D+0, +9.99994 29607 47082 9D-1/
      DATA B2
     1/+0.00000 00000 00000 0D+0, +6.95000 65588 74339 8D+1,
     2 +5.72837 19383 73237 2D+1, +2.57776 38423 84398 7D+1,
     3 +7.60761 14800 77345 8D+2, +2.89516 72792 51350 5D+1,
     4 -3.43942 26689 98699 7D+0, +1.00083 86740 26391 2D+0/
      DATA A3
     1/-5.31686 62349 44816 2D+1, +8.91263 82257 37077 5D+0,
     2 -1.39381 36036 44050 7D+0, -3.08336 26905 17627 0D+1,
     3 -7.49289 16779 28844 3D+0, -5.00140 34551 59243 5D+0,
     4 -3.00000 01678 20851 8D+0, +1.00000 00000 00583 9D+0/
      DATA B3
     1/+0.00000 00000 00000 0D+0, +1.04745 36265 24683 0D+3,
     2 -6.74704 58046 58324 3D+0, +2.95999 39948 68313 3D+2,
     3 -4.31325 83614 66279 6D+0, -7.90404 99229 89255 1D+0,
     4 -2.99996 43294 44464 6D+0, +1.99999 99992 41308 9D+0/

       LEX=.FALSE.
       GO TO 9

       ENTRY DEXPIE
       LEX=.TRUE.

    9 IF(X .LE. -24) THEN
       AP=A3(1)-X
       DO 1 I = 2,7
    1  AP=A3(I)-X+B3(I)/AP
       H=(1-(A3(8)+B3(8)/AP)/X)/X
       IF(.NOT.LEX) H=EXP(-X)*H
      ELSE IF(X .LE. -12) THEN
       AP=A2(1)-X
       DO 2 I = 2,7
    2  AP=A2(I)-X+B2(I)/AP
       H=(A2(8)+B2(8)/AP)/X
       IF(.NOT.LEX) H=EXP(-X)*H
      ELSE IF(X .LE. -6) THEN
       AP=A1(1)-X
       DO 3 I = 2,7
    3  AP=A1(I)-X+B1(I)/AP
       H=(A1(8)+B1(8)/AP)/X
       IF(.NOT.LEX) H=EXP(-X)*H
      ELSE IF(X .LT. 0) THEN
       V=R3*X-2
       BP=0
       DP=P4(1)
       DO 4 I = 2,8
       AP=BP
       BP=DP
    4  DP=P4(I)-AP+V*BP
       BQ=0
       DQ=Q4(1)
       DO 14 I = 2,8
       AQ=BQ
       BQ=DQ
   14  DQ=Q4(I)-AQ+V*BQ
       H=-LOG(-X/X0)+(X+X0)*(DP-AP)/(DQ-AQ)
       IF(LEX) H=EXP(X)*H
      ELSE IF(X .EQ. 0) THEN
       H=0
       IF(.NOT.LEX) CALL MTLPRT(NAME ,'C337.1','ARGUMENT X = 0')
       IF(     LEX) CALL MTLPRT(NAMEE,'C337.1','ARGUMENT X = 0')
      ELSE IF(X .LT. 1) THEN
       AP=P1(1)
       AQ=Q1(1)
       DO 5 I = 2,5
       AP=P1(I)+X*AP
    5  AQ=Q1(I)+X*AQ
       H=-LOG(X)+AP/AQ
       IF(LEX) H=EXP(X)*H
      ELSE IF(X .LE. 4) THEN
       Y=1/X
       AP=P2(1)
       AQ=Q2(1)
       DO 6 I = 2,7
       AP=P2(I)+Y*AP
    6  AQ=Q2(I)+Y*AQ
       H=AP/AQ
       IF(.NOT.LEX) H=EXP(-X)*H
      ELSE
       Y=1/X
       AP=P3(1)
       AQ=Q3(1)
       DO 7 I = 2,7
       AP=P3(I)+Y*AP
    7  AQ=Q3(I)+Y*AQ
       H=Y*(1+Y*AP/AQ)
       IF(.NOT.LEX) H=EXP(-X)*H
      END IF
      DEXPIN=H
      RETURN
      END
CDECK  ID>, CEXPIN. 
      FUNCTION CEXPIN(Z)
      COMPLEX CEXPIN,Z
      COMPLEX*16
     +     WEXPIN,W
      DOUBLE PRECISION
     +     D

      SROUND(D)=D+(D-SNGL(D))
      W=Z
      W=WEXPIN(W)
      CEXPIN=CMPLX(SROUND(DREAL(W)),SROUND(DIMAG(W)))
      RETURN
      END
CDECK  ID>, CEXPIN64.   
      FUNCTION WEXPIN(Z)
      IMPLICIT COMPLEX*16 (A-H,I,O-Z)
      DOUBLE PRECISION
     +      AC,BC,CC,DC,CE,W,X,EPS,CONST,Z1,HF,HC,ZR,ZI,R1,R2,R3,R4
      CHARACTER NAME*(*)
      PARAMETER (NAME = 'CEXPIN/WEXPIN')
      PARAMETER (EPS = 1D-13)
      PARAMETER (CE = 0.57721 56649 01532 86D0)
      PARAMETER (Z1 = 1, HF = Z1/2, HC = 0.005D0)
      PARAMETER (R1 = Z1/7, R2 = Z1/5, R3 = Z1/15, R4 = Z1/12)


      DIMENSION AC(10),BC(10),CC(16),DC(16),W(12),X(12)


      DATA AC( 1) /0.20502 08456 77917 066D  0/
      DATA AC( 2) /0.39390 75193 16296 552D -1/
      DATA AC( 3) /0.34858 23655 29237 912D -2/
      DATA AC( 4) /0.29317 75506 14266 489D -3/
      DATA AC( 5) /0.13754 73570 29922 394D -4/
      DATA AC( 6) /0.60964 46174 77455 800D -6/
      DATA AC( 7) /0.14447 18655 00891 748D -7/
      DATA AC( 8) /0.30430 04327 31332 247D -9/
      DATA AC( 9) /0.22059 38908 74765 263D-11/
      DATA AC(10) /0.49848 28058 16872 883D-14/

      DATA BC( 1) /0.45502 08456 77917 066D  0/
      DATA BC( 2) /0.97590 40779 55533 663D -1/
      DATA BC( 3) /0.13021 15639 98519 948D -1/
      DATA BC( 4) /0.11999 11137 74704 761D -2/
      DATA BC( 5) /0.80015 09559 21661 460D -4/
      DATA BC( 6) /0.39222 83073 88575 923D -5/
      DATA BC( 7) /0.14003 62118 96032 452D -6/
      DATA BC( 8) /0.34984 41348 05290 456D -8/
      DATA BC( 9) /0.55465 89453 73869 458D-10/
      DATA BC(10) /0.42591 33901 24021 430D-12/

      DATA CC( 1) /                271D0/
      DATA CC( 2) /              32370D0/
      DATA CC( 3) /           22 52698D0/
      DATA CC( 4) /         1017 37272D0/
      DATA CC( 5) /        31439 23848D0/
      DATA CC( 6) /      6 83085 03120D0/
      DATA CC( 7) /    105 58823 22000D0/
      DATA CC( 8) /   1161 90773 74080D0/
      DATA CC( 9) /   9018 57120 59520D0/
      DATA CC(10) /  48411 83190 41280D0/
      DATA CC(11) /1 73907 98760 38400D0/
      DATA CC(12) /3 96823 48312 32000D0/
      DATA CC(13) /5 28572 15615 23200D0/
      DATA CC(14) /3 54121 43251 96800D0/
      DATA CC(15) /  86771 81624 83200D0/
      DATA CC(16) /   2092 27898 88000D0/

      DATA DC( 1) /                272D0/
      DATA DC( 2) /              32640D0/
      DATA DC( 3) /           22 84800D0/
      DATA DC( 4) /         1039 58400D0/
      DATA DC( 5) /        32435 02080D0/
      DATA DC( 6) /      7 13570 45760D0/
      DATA DC( 7) /    112 13250 04800D0/
      DATA DC( 8) /   1261 49063 04000D0/
      DATA DC( 9) /  10091 92504 32000D0/
      DATA DC(10) /  56514 78024 19200D0/
      DATA DC(11) /2 15783 70637 82400D0/
      DATA DC(12) /5 39459 26594 56000D0/
      DATA DC(13) /8 29937 33222 40000D0/
      DATA DC(14) /7 11374 85619 20000D0/
      DATA DC(15) /2 84549 94247 68000D0/
      DATA DC(16) /  35568 74280 96000D0/

      DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
      DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
      DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
      DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
      DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
      DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
      DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
      DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
      DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
      DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
      DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
      DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/

      DOUBLE PRECISION
     +      GREAL,GIMAG,XARG,YARG
      COMPLEX*16
     +      ZARG,GCONJG,GCMPLX
      GREAL( ZARG)=DREAL( ZARG)
      GIMAG( ZARG)=DIMAG( ZARG)
      GCONJG(ZARG)=DCONJG(ZARG)
      GCMPLX(XARG,YARG)=DCMPLX(XARG,YARG)

      F(T)=(1-EXP(-T))/T

      ZI=ABS(GIMAG(Z))
      ZR=Z
      IF(ZR .GE. -5 .AND. (R1*(ZR-1))**2+(R2*ZI)**2 .LE. 1) THEN
       G=AC(10)
       H=BC(10)
       DO 1 K = 9,1,-1
       G=G*Z+AC(K)
    1  H=H*Z+BC(K)
       H=((1+G*Z)/(1+H*Z))*Z
      ELSEIF(ZI .GE. 12 .OR.
     1       ZR .GT. -12 .AND. (R3*(ZR+12))**2+(R4*ZI)**2 .GE. 1) THEN
       G=Z+CC(1)
       H=Z+DC(1)
       DO 2 K = 2,16
       G=G*Z+CC(K)
    2  H=H*Z+DC(K)
       H=(G/H)*EXP(-Z)/Z+LOG(Z)+CE
      ELSE
       H=0
       CONST=HC/ABS(Z)
       BB=0
   11  AA=BB
       BB=Z
   12  C1=HF*(BB+AA)
       C2=HF*(BB-AA)
       S8=0
       DO 13 K = 1,4
       U=C2*X(K)
   13  S8=S8+W(K)*(F(C1+U)+F(C1-U))
       S16=0
       DO 14 K = 5,12
       U=C2*X(K)
   14  S16=S16+W(K)*(F(C1+U)+F(C1-U))
       S16=C2*S16
       IF(ABS(S16-C2*S8) .LE. EPS*(1+ABS(S16))) THEN
        H=H+S16
        IF(BB .NE. Z) GO TO 11
       ELSE
        BB=C1
        IF(1+CONST*ABS(C2) .NE. 1) GO TO 12
        H=0
        CALL MTLPRT(NAME,'C338.1','TOO HIGH ACCURACY REQUIRED')
        WEXPIN=0.
        RETURN
       END IF
      ENDIF
      WEXPIN=H
      RETURN
      END
CDECK  ID>, DAWSON. 
      FUNCTION DAWSON(X)
      DOUBLE PRECISION
     +      DDAWSN,D

      SROUND(D)=D+(D-SNGL(D))
      DAWSON=SROUND(DDAWSN(DBLE(X)))
      RETURN
      END
CDECK  ID>, DAWSON64.   
      FUNCTION DDAWSN(X)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      DIMENSION P1(0:8),Q1(0:8)
      DIMENSION A1(0:7),B1(0:6),A2(0:7),B2(0:6),A3(0:5),B3(0:4)

      PARAMETER (Z1 = 1, HF = Z1/2, C1 = 2+HF, C2 = 3+HF)

      DATA P1
     1/+1.73971 38358 72305 8D+8, -2.35903 54309 49078 4D+7,
     2 +7.94595 11256 26974 7D+6, -4.49408 95997 95344 8D+5,
     3 +6.26435 22480 53304 3D+4, -1.64294 23044 87861 4D+3,
     4 +1.10415 15859 64097 2D+2, -1.23806 01126 69044 4D+0,
     5 +1.70141 56251 64813 2D-2/
      DATA Q1
     1/+1.73971 38358 72305 8D+8, +9.23905 68081 99581 7D+7,
     2 +2.31472 94223 70433 8D+7, +3.59959 82595 90670 4D+6,
     3 +3.83498 04512 71685 6D+5, +2.90022 12938 95164 3D+4,
     4 +1.54480 44953 25198 3D+3, +5.42357 27435 06117 3D+1,
     5 +1.00000 00000 00000 0D+0/
      DATA A1
     1/+5.00236 89608 86678 8D-1, -5.97678 08682 34888 6D+0,
     2 +1.52644 09962 36985 9D+1, -8.89106 47974 78123 3D+0,
     3 -7.57931 91808 93692 7D-2, -4.00000 89364 35497 2D+1,
     4 +2.93365 74739 54485 3D+1, -1.50695 65118 71605 5D+0/
      DATA A2
     1/+4.99999 90270 50535 9D-1, -1.49838 04203 66907 2D+0,
     2 -4.98544 80298 66076 7D+0, +5.06460 15374 22307 7D+0,
     3 -1.50507 70349 66919 6D+1, -9.16804 87981 35517 1D+0,
     4 -2.66167 67489 63992 8D+1, +4.76405 64527 32287 8D+0/
      DATA A3
     1/+5.00000 00000 87358 0D-1, -2.50000 27830 30495 0D+0,
     2 -4.51057 82777 83269 5D+0, -7.82636 28103 36344 1D+0,
     3 -4.05239 81738 80339 4D+1, +4.12716 33274 69802 1D+0/
      DATA B1
     1/+2.26064 66607 43091 6D-1, +1.15840 29255 18881 3D+2,
     2 +7.29177 55641 55315 0D+1, +1.12461 66202 45754 3D+2,
     3 +7.21193 21760 02290 6D+0, +1.24486 78826 22516 2D+3,
     4 -6.73106 06974 48133 1D-1/
      DATA B2
     1/+2.50011 45961 18389 4D-1, -1.48715 81178 71947 5D+0,
     2 +3.30707 72467 61143 7D+1, +1.46515 16778 31092 9D+2,
     3 +7.51701 27774 40669 3D+1, +2.56105 72234 22263 5D+1,
     4 +2.87776 12297 31873 6D+2/
      DATA B3
     1/+7.49999 99263 58122 3D-1, -2.49963 00606 78980 2D+0,
     2 -6.58834 68001 31477 4D+0, -6.89636 11433 76130 9D-1,
     3 +5.20416 17289 69394 6D+2/

      V=ABS(X)
      Y=V**2
      IF(V .LT. C1) THEN
       P=P1(8)
       Q=Q1(8)
       DO 1 I = 7,0,-1
       P=Y*P+P1(I)
    1  Q=Y*Q+Q1(I)
       H=X*P/Q
      ELSE IF(V .LT. C2) THEN
       P=Y+A1(7)
       DO 2 I = 6,1,-1
    2  P=Y+A1(I)+B1(I)/P
       H=(A1(0)+B1(0)/P)/X
      ELSE IF(V .LT. 5) THEN
       P=Y+A2(7)
       DO 3 I = 6,1,-1
    3  P=Y+A2(I)+B2(I)/P
       H=(A2(0)+B2(0)/P)/X
      ELSE
       P=Y+A3(5)
       DO 4 I = 4,1,-1
    4  P=Y+A3(I)+B3(I)/P
       H=(HF+HF*(A3(0)+B3(0)/P)/Y)/X
      END IF
      DDAWSN=H
      RETURN
      END
CDECK  ID>, BSIR3.  
      FUNCTION BSIR3(X,NU)
C     IMPLICIT DOUBLE PRECISION (D)
      DOUBLE PRECISION
     +    D,DBSIR3,DBLE,DBSKR3,DEBIR3,DEBKR3

      SROUND(D)=D+(D-SNGL(D))
      BSIR3=SROUND(DBSIR3(DBLE(X),NU))
      RETURN

      ENTRY BSKR3(X,NU)
      BSKR3=SROUND(DBSKR3(DBLE(X),NU))
      RETURN

      ENTRY EBSIR3(X,NU)
      EBSIR3=SROUND(DEBIR3(DBLE(X),NU))
      RETURN

      ENTRY EBSKR3(X,NU)
      EBSKR3=SROUND(DEBKR3(DBLE(X),NU))
      RETURN
      END
CDECK  ID>, BSIR364.
      FUNCTION DBSIR3(X,NU)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      CHARACTER*80 ERRTXT
      CHARACTER NAMEI*(*),NAMEK*(*),NAMEIE*(*),NAMEKE*(*)
      PARAMETER (NAMEI = 'BSIR3/DBSIR3', NAMEIE = 'EBSIR3/DEBIR3')
      PARAMETER (NAMEK = 'BSKR3/DBSKR3', NAMEKE = 'EBSKR3/DEBKR3')
      LOGICAL LEX

      DIMENSION BC(0:23,2),CC(0:15,2),PP(-2:2),GG(-2:2)

      PARAMETER (EPS = 1D-15)
      PARAMETER (Z1 = 1, HF = Z1/2)
      PARAMETER (PI = 3.14159 26535 89793 24D0)
      PARAMETER (W3 = 1.73205 08075 68877 29D0)
      PARAMETER (G1 = 2.67893 85347 07747 63D0)
      PARAMETER (G2 = 1.35411 79394 26400 42D0)
      PARAMETER (PIH = PI/2, RPIH = 2/PI, RPI2 = 1/(2*PI))
      PARAMETER (C1 = 2*PI/(3*W3))
      PARAMETER (GM = 3*(1/G2-3/G1)/2, GP = (3/G1+1/G2)/2)

      DATA PP(-2) /-0.66666 66666 66666 67D0/
      DATA PP(-1) /-0.33333 33333 33333 33D0/
      DATA PP( 1) / 0.33333 33333 33333 33D0/
      DATA PP( 2) / 0.66666 66666 66666 67D0/

      DATA GG(-2) / 0.37328 21739 07395 23D0/
      DATA GG(-1) / 0.73848 81116 21648 31D0/
      DATA GG( 1) / 1.11984 65217 22185 68D0/
      DATA GG( 2) / 1.10773 21674 32472 47D0/

      DATA BC( 0,1) / 1.00458 61710 93207 35D0/
      DATA BC( 1,1) / 0.00467 34791 99873 60D0/
      DATA BC( 2,1) / 0.00009 08034 04815 04D0/
      DATA BC( 3,1) / 0.00000 37262 16110 59D0/
      DATA BC( 4,1) / 0.00000 02520 73237 90D0/
      DATA BC( 5,1) / 0.00000 00227 82110 77D0/
      DATA BC( 6,1) / 0.00000 00012 91332 28D0/
      DATA BC( 7,1) /-0.00000 00006 11915 16D0/
      DATA BC( 8,1) /-0.00000 00003 75616 85D0/
      DATA BC( 9,1) /-0.00000 00001 16415 46D0/
      DATA BC(10,1) /-0.00000 00000 14443 25D0/
      DATA BC(11,1) / 0.00000 00000 05373 69D0/
      DATA BC(12,1) / 0.00000 00000 03074 27D0/
      DATA BC(13,1) / 0.00000 00000 00297 66D0/
      DATA BC(14,1) /-0.00000 00000 00265 20D0/
      DATA BC(15,1) /-0.00000 00000 00091 37D0/
      DATA BC(16,1) / 0.00000 00000 00015 52D0/
      DATA BC(17,1) / 0.00000 00000 00014 12D0/
      DATA BC(18,1) /-0.00000 00000 00000 23D0/
      DATA BC(19,1) /-0.00000 00000 00001 98D0/
      DATA BC(20,1) /-0.00000 00000 00000 13D0/
      DATA BC(21,1) / 0.00000 00000 00000 29D0/
      DATA BC(22,1) / 0.00000 00000 00000 03D0/
      DATA BC(23,1) /-0.00000 00000 00000 05D0/

      DATA BC( 0,2) / 0.99363 49867 16925 14D0/
      DATA BC( 1,2) /-0.00646 71526 00616 03D0/
      DATA BC( 2,2) /-0.00010 60188 22351 55D0/
      DATA BC( 3,2) /-0.00000 41406 57716 24D0/
      DATA BC( 4,2) /-0.00000 02916 95418 21D0/
      DATA BC( 5,2) /-0.00000 00365 71574 33D0/
      DATA BC( 6,2) /-0.00000 00075 81590 37D0/
      DATA BC( 7,2) /-0.00000 00019 23008 52D0/
      DATA BC( 8,2) /-0.00000 00004 20438 80D0/
      DATA BC( 9,2) /-0.00000 00000 39372 04D0/
      DATA BC(10,2) / 0.00000 00000 19007 44D0/
      DATA BC(11,2) / 0.00000 00000 10137 64D0/
      DATA BC(12,2) / 0.00000 00000 01331 30D0/
      DATA BC(13,2) /-0.00000 00000 00676 92D0/
      DATA BC(14,2) /-0.00000 00000 00311 72D0/
      DATA BC(15,2) / 0.00000 00000 00011 87D0/
      DATA BC(16,2) / 0.00000 00000 00040 21D0/
      DATA BC(17,2) / 0.00000 00000 00004 78D0/
      DATA BC(18,2) /-0.00000 00000 00004 74D0/
      DATA BC(19,2) /-0.00000 00000 00001 16D0/
      DATA BC(20,2) / 0.00000 00000 00000 59D0/
      DATA BC(21,2) / 0.00000 00000 00000 21D0/
      DATA BC(22,2) /-0.00000 00000 00000 08D0/
      DATA BC(23,2) /-0.00000 00000 00000 03D0/

      DATA CC( 0,1) / 0.99353 64122 76093 39D0/
      DATA CC( 1,1) /-0.00631 44392 60798 63D0/
      DATA CC( 2,1) / 0.00014 30095 80961 13D0/
      DATA CC( 3,1) /-0.00000 57870 60592 03D0/
      DATA CC( 4,1) / 0.00000 03265 50333 20D0/
      DATA CC( 5,1) /-0.00000 00231 23231 95D0/
      DATA CC( 6,1) / 0.00000 00019 39555 14D0/
      DATA CC( 7,1) /-0.00000 00001 85897 89D0/
      DATA CC( 8,1) / 0.00000 00000 19868 42D0/
      DATA CC( 9,1) /-0.00000 00000 02326 79D0/
      DATA CC(10,1) / 0.00000 00000 00294 68D0/
      DATA CC(11,1) /-0.00000 00000 00039 95D0/
      DATA CC(12,1) / 0.00000 00000 00005 75D0/
      DATA CC(13,1) /-0.00000 00000 00000 87D0/
      DATA CC(14,1) / 0.00000 00000 00000 14D0/
      DATA CC(15,1) /-0.00000 00000 00000 02D0/

      DATA CC( 0,2) / 1.00914 95380 72789 40D0/
      DATA CC( 1,2) / 0.00897 12068 42483 60D0/
      DATA CC( 2,2) /-0.00017 13895 98261 54D0/
      DATA CC( 3,2) / 0.00000 65547 92549 82D0/
      DATA CC( 4,2) /-0.00000 03595 19190 49D0/
      DATA CC( 5,2) / 0.00000 00250 24412 19D0/
      DATA CC( 6,2) /-0.00000 00020 74924 13D0/
      DATA CC( 7,2) / 0.00000 00001 97223 67D0/
      DATA CC( 8,2) /-0.00000 00000 20946 47D0/
      DATA CC( 9,2) / 0.00000 00000 02440 93D0/
      DATA CC(10,2) /-0.00000 00000 00307 91D0/
      DATA CC(11,2) / 0.00000 00000 00041 61D0/
      DATA CC(12,2) /-0.00000 00000 00005 97D0/
      DATA CC(13,2) / 0.00000 00000 00000 91D0/
      DATA CC(14,2) /-0.00000 00000 00000 14D0/
      DATA CC(15,2) / 0.00000 00000 00000 02D0/

      LEX=.FALSE.
      GO TO 8

      ENTRY DEBIR3(X,NU)
      LEX=.TRUE.

    8 MU=ABS(NU)
      IF(MU .NE. 1 .AND. MU .NE. 2 .OR. NU .LT. 0 .AND. X .LE. 0
     1   .OR. NU .GT. 0 .AND. X .LT. 0) THEN
       S=0
       WRITE(ERRTXT,101) X,NU
       IF(.NOT.LEX) CALL MTLPRT(NAMEI ,'C340.1',ERRTXT)
       IF(     LEX) CALL MTLPRT(NAMEIE,'C340.1',ERRTXT)
      ELSEIF(X .EQ. 0) THEN
       S=0
      ELSEIF(X .LT. 8) THEN
       Y=(HF*X)**2
       XN=PP(NU)
       XL=XN+2
       A0=1
       A1=1+2*Y/((XL+1)*(XN+1))
       A2=1+Y*(4+3*Y/((XL+2)*(XN+2)))/((XL+3)*(XN+1))
       B0=1
       B1=1-Y/(XL+1)
       B2=1-Y*(1-Y/(2*(XL+2)))/(XL+3)
       T1=3+XL
       V1=3-XL
       V3=XL-1
       V2=V3+V3
       C=0
       DO 33 N = 3,30
       C0=C
       T1=T1+2
       T2=T1-1
       T3=T2-1
       T4=T3-1
       T5=T4-1
       T6=T5-1
       V1=V1+1
       V2=V2+1
       V3=V3+1
       U1=N*T4
       E=V3/(U1*T3)
       U2=E*Y
       F1=1+Y*V1/(U1*T1)
       F2=(1+Y*V2/(V3*T2*T5))*U2
       F3=-Y*Y*U2/(T4*T5*T5*T6)
       A=F1*A2+F2*A1+F3*A0
       B=F1*B2+F2*B1+F3*B0
       C=A/B
       IF(ABS(C0-C) .LT. EPS*ABS(C)) GO TO 34
       A0=A1
       A1=A2
       A2=A
       B0=B1
       B1=B2
       B2=B
   33  CONTINUE
   34  S=GG(NU)*(HF*X)**PP(NU)*C
       IF(LEX) S=EXP(-X)*S
      ELSE
       R=1/X
       W=SQRT(RPI2*R)
       H=16*R-1
       ALFA=H+H
       B1=0
       B2=0
       DO 2 I = 23,0,-1
       B0=BC(I,MU)+ALFA*B1-B2
       B2=B1
    2  B1=B0
       S=W*(B0-H*B2)
       IF(.NOT.LEX) S=EXP(X)*S
       T=0
       IF(NU .LT. 0) THEN
        H=10*R-1
        ALFA=H+H
        B1=0
        B2=0
        DO 3 I = 15,0,-1
        B0=CC(I,MU)+ALFA*B1-B2
        B2=B1
    3   B1=B0
        R=EXP(-X)
        T=W3*W*R*(B0-H*B2)
        IF(LEX) T=R*T
       END IF
       S=S+T
      END IF
      GO TO 99

      ENTRY DBSKR3(X,NU)
      LEX=.FALSE.
      GO TO 9

      ENTRY DEBKR3(X,NU)
      LEX=.TRUE.

    9 MU=ABS(NU)
      IF(MU .NE. 1 .AND. MU .NE. 2 .OR. X .LE. 0) THEN
       S=0
       WRITE(ERRTXT,101) X,NU
       IF(.NOT.LEX) CALL MTLPRT(NAMEK ,'C340.1',ERRTXT)
       IF(     LEX) CALL MTLPRT(NAMEKE,'C340.1',ERRTXT)
      ELSEIF(X .LE. 1) THEN
       A0=PP(-1)
       B=HF*X
       D=-LOG(B)
       F=A0*D
       E=EXP(F)
       G=(GM*A0+GP)*E
       BK=C1*(HF*GM*(E+1/E)+GP*D*SINH(F)/F)
       F=BK
       E=A0**2
       P=HF*C1*G
       Q=HF/G
       C=1
       D=B**2
       BK1=P
       DO 11 N = 1,15
       FN=N
       F=(FN*F+P+Q)/(FN**2-E)
       C=C*D/FN
       P=P/(FN-A0)
       Q=Q/(FN+A0)
       G=C*(P-FN*F)
       H=C*F
       BK=BK+H
       BK1=BK1+G
       IF(H*BK1+ABS(G)*BK .LE. EPS*BK*BK1) GO TO 12
   11  CONTINUE
   12  S=BK
       IF(MU .EQ. 2) S=BK1/B
       IF(LEX) S=EXP(X)*S
      ELSEIF(X .LE. 5) THEN
       XN=4*PP(MU)**2
       A=9-XN
       B=25-XN
       C=768*X**2
       C0=48*X
       A0=1
       A1=(16*X+7+XN)/A
       A2=(C+C0*(XN+23)+XN*(XN+62)+129)/(A*B)
       B0=1
       B1=(16*X+9-XN)/A
       B2=(C+C0*B)/(A*B)+1
       C=0
       DO 24 N = 3,30
       C0=C
       FN=N
       FN2=FN+FN
       FN1=FN2-1
       FN3=FN1/(FN2-3)
       FN4=12*FN**2-(1-XN)
       FN5=16*FN1*X
       RAN=1/((FN2+1)**2-XN)
       F1=FN3*(FN4-20*FN)+FN5
       F2=28*FN-FN4-8+FN5
       F3=FN3*((FN2-5)**2-XN)
       A=(F1*A2+F2*A1+F3*A0)*RAN
       B=(F1*B2+F2*B1+F3*B0)*RAN
       C=A/B
       IF(ABS(C0-C) .LT. EPS*ABS(C)) GO TO 25
       A0=A1
       A1=A2
       A2=A
       B0=B1
       B1=B2
       B2=B
   24  CONTINUE
   25  S=C/SQRT(RPIH*X)
       IF(.NOT.LEX) S=EXP(-X)*S
      ELSE
       R=1/X
       H=10*R-1
       ALFA=H+H
       B1=0
       B2=0
       DO 13 I = 15,0,-1
       B0=CC(I,MU)+ALFA*B1-B2
       B2=B1
   13  B1=B0
       S=SQRT(PIH*R)*(B0-H*B2)
       IF(.NOT.LEX) S=EXP(-X)*S
      END IF
   99 DBSIR3=S
      RETURN
  101 FORMAT('INCORRECT ARGUMENT OR INDEX, X = ',1P,E15.6,' NU = ',I5)
      END
CDECK  ID>, STRH0.  
      FUNCTION STRH0(X)
      DOUBLE PRECISION
     +      DSTRH0,DSTRH1,D

      SROUND(D)=D+(D-SNGL(D))
      STRH0=SROUND(DSTRH0(DBLE(X)))
      RETURN

      ENTRY STRH1(X)

      STRH1=SROUND(DSTRH1(DBLE(X)))
      RETURN
      END
CDECK  ID>, STRH064.
      FUNCTION DSTRH0(X)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      DIMENSION C1(0:15),C2(0:25),C3(0:16),C4(0:22)

      PARAMETER (Z1 = 1, R8 = Z1/8, R32 = Z1/32, CS = 3*Z1/10)
      PARAMETER (PI = 3.14159 26535 89793 24D0)
      PARAMETER (C0 = 2/PI, CC = 2/(3*PI))

      DATA N1,N2,N3,N4 /15,25,16,22/

      DATA C1( 0) / 1.00215 84560 99119 81D0/
      DATA C1( 1) /-1.63969 29268 13091 47D0/
      DATA C1( 2) / 1.50236 93961 82928 19D0/
      DATA C1( 3) /-0.72485 11530 21218 72D0/
      DATA C1( 4) / 0.18955 32737 10931 36D0/
      DATA C1( 5) /-0.03067 05202 29880 00D0/
      DATA C1( 6) / 0.00337 56144 73751 94D0/
      DATA C1( 7) /-0.00026 96501 43126 02D0/
      DATA C1( 8) / 0.00001 63746 16926 12D0/
      DATA C1( 9) /-0.00000 07824 44085 08D0/
      DATA C1(10) / 0.00000 00302 15931 88D0/
      DATA C1(11) /-0.00000 00009 63266 45D0/
      DATA C1(12) / 0.00000 00000 25793 37D0/
      DATA C1(13) /-0.00000 00000 00588 54D0/
      DATA C1(14) / 0.00000 00000 00011 58D0/
      DATA C1(15) /-0.00000 00000 00000 20D0/

      DATA C2( 0) / 0.99283 72757 64239 43D0/
      DATA C2( 1) /-0.00696 89128 11386 25D0/
      DATA C2( 2) / 0.00018 20510 37870 37D0/
      DATA C2( 3) /-0.00001 06325 82528 44D0/
      DATA C2( 4) / 0.00000 09819 82942 87D0/
      DATA C2( 5) /-0.00000 01225 06454 45D0/
      DATA C2( 6) / 0.00000 00189 40833 12D0/
      DATA C2( 7) /-0.00000 00034 43582 26D0/
      DATA C2( 8) / 0.00000 00007 11191 02D0/
      DATA C2( 9) /-0.00000 00001 62887 44D0/
      DATA C2(10) / 0.00000 00000 40656 81D0/
      DATA C2(11) /-0.00000 00000 10915 05D0/
      DATA C2(12) / 0.00000 00000 03120 05D0/
      DATA C2(13) /-0.00000 00000 00942 02D0/
      DATA C2(14) / 0.00000 00000 00298 48D0/
      DATA C2(15) /-0.00000 00000 00098 72D0/
      DATA C2(16) / 0.00000 00000 00033 94D0/
      DATA C2(17) /-0.00000 00000 00012 08D0/
      DATA C2(18) / 0.00000 00000 00004 44D0/
      DATA C2(19) /-0.00000 00000 00001 68D0/
      DATA C2(20) / 0.00000 00000 00000 65D0/
      DATA C2(21) /-0.00000 00000 00000 26D0/
      DATA C2(22) / 0.00000 00000 00000 11D0/
      DATA C2(23) /-0.00000 00000 00000 04D0/
      DATA C2(24) / 0.00000 00000 00000 02D0/
      DATA C2(25) /-0.00000 00000 00000 01D0/

      DATA C3( 0) / 0.55788 91446 48160 50D0/
      DATA C3( 1) /-0.11188 32572 65698 16D0/
      DATA C3( 2) /-0.16337 95812 52009 39D0/
      DATA C3( 3) / 0.32256 93207 24059 02D0/
      DATA C3( 4) /-0.14581 63236 72442 42D0/
      DATA C3( 5) / 0.03292 67739 93740 35D0/
      DATA C3( 6) /-0.00460 37214 20935 73D0/
      DATA C3( 7) / 0.00044 34706 16331 40D0/
      DATA C3( 8) /-0.00003 14209 95293 41D0/
      DATA C3( 9) / 0.00000 17123 71993 80D0/
      DATA C3(10) /-0.00000 00741 69870 05D0/
      DATA C3(11) / 0.00000 00026 18376 71D0/
      DATA C3(12) /-0.00000 00000 76858 39D0/
      DATA C3(13) / 0.00000 00000 01906 70D0/
      DATA C3(14) /-0.00000 00000 00040 52D0/
      DATA C3(15) / 0.00000 00000 00000 75D0/
      DATA C3(16) /-0.00000 00000 00000 01D0/

      DATA C4( 0) / 1.00757 64729 38656 41D0/
      DATA C4( 1) / 0.00750 31605 12482 57D0/
      DATA C4( 2) /-0.00007 04393 32645 19D0/
      DATA C4( 3) / 0.00000 26620 53933 82D0/
      DATA C4( 4) /-0.00000 01884 11577 53D0/
      DATA C4( 5) / 0.00000 00194 90149 58D0/
      DATA C4( 6) /-0.00000 00026 12619 90D0/
      DATA C4( 7) / 0.00000 00004 23626 90D0/
      DATA C4( 8) /-0.00000 00000 79551 56D0/
      DATA C4( 9) / 0.00000 00000 16799 73D0/
      DATA C4(10) /-0.00000 00000 03907 20D0/
      DATA C4(11) / 0.00000 00000 00985 43D0/
      DATA C4(12) /-0.00000 00000 00266 36D0/
      DATA C4(13) / 0.00000 00000 00076 45D0/
      DATA C4(14) /-0.00000 00000 00023 13D0/
      DATA C4(15) / 0.00000 00000 00007 33D0/
      DATA C4(16) /-0.00000 00000 00002 42D0/
      DATA C4(17) / 0.00000 00000 00000 83D0/
      DATA C4(18) /-0.00000 00000 00000 30D0/
      DATA C4(19) / 0.00000 00000 00000 11D0/
      DATA C4(20) /-0.00000 00000 00000 04D0/
      DATA C4(21) / 0.00000 00000 00000 02D0/
      DATA C4(22) /-0.00000 00000 00000 01D0/

      V=ABS(X)
      IF(V .LT. 8) THEN
       Y=R8*V
       H=2*Y**2-1
       ALFA=H+H
       B1=0
       B2=0
       DO 1 I = N1,0,-1
       B0=C1(I)+ALFA*B1-B2
       B2=B1
    1  B1=B0
       H=Y*(B0-H*B2)
      ELSE
       R=1/V
       H=128*R**2-1
       ALFA=H+H
       B1=0
       B2=0
       DO 2 I = N2,0,-1
       B0=C2(I)+ALFA*B1-B2
       B2=B1
    2  B1=B0
       H=DBESY0(V)+C0*R*(B0-H*B2)
      END IF
      IF(X .LT. 0) H=-H
      GO TO 9

      ENTRY DSTRH1(X)

      V=ABS(X)
      IF(V .EQ. 0) THEN
       H=0
      ELSEIF(V .LE. CS) THEN
       Y=V**2
       R=1
       H=1
       DO 5 N = 1,INT(-8/LOG10(V))
       H=-H*Y/((2*N+1)*(2*N+3))
    5  R=R+H
       H=CC*Y*R
      ELSE IF(V .LT. 8) THEN
       H=R32*V**2-1
       ALFA=H+H
       B1=0
       B2=0
       DO 3 I = N3,0,-1
       B0=C3(I)+ALFA*B1-B2
       B2=B1
    3  B1=B0
       H=B0-H*B2
      ELSE
       H=128/V**2-1
       ALFA=H+H
       B1=0
       B2=0
       DO 4 I = N4,0,-1
       B0=C4(I)+ALFA*B1-B2
       B2=B1
    4  B1=B0
       H=DBESY1(V)+C0*(B0-H*B2)
      END IF
    9 DSTRH0=H
      RETURN
      END
CDECK  ID>, BSJA.   
      SUBROUTINE BSJA(X,A,NMAX,ND,B)
      DOUBLE PRECISION D,DB(0:101)
      DIMENSION B(0:*)

      SROUND(D)=D+(D-SNGL(D))
      CALL DBSJA(DBLE(X),DBLE(A),NMAX,ND,DB)
      GO TO 2

      ENTRY BSIA(X,A,NMAX,ND,B)

      CALL DBSIA(DBLE(X),DBLE(A),NMAX,ND,DB)
    2 DO 1 N = 0,ABS(NMAX)
    1 B(N)=SROUND(DB(N))
      RETURN
      END
CDECK  ID>, BSJA64. 
      SUBROUTINE DBSJA(X,A,NMAX,ND,B)

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      REAL SX,D,T,Q,U,V,TC(11)
      CHARACTER*80 ERRTXT
      CHARACTER NAMEJ*(*),NAMEI*(*)
      PARAMETER (NAMEJ = 'BSJA/DBSJA',
     1           NAMEI = 'BSIA/DBSIA')
      LOGICAL LJA,LIA,LEV,LER
      DIMENSION B(0:*),BA(0:100),RR(0:100)

      PARAMETER (Z1 = 1, HF = Z1/2, Z10 = 10)

      DATA TC / 5.7941 E-5,-1.76148E-3, 2.08645E-2,-1.29013E-1,
     1          8.5777 E-1, 1.0125 E+0, 7.75   E-1, 2.3026 E+0,
     2          1.3863 E+0, 7.3576 E-1, 1.3591 E+0/

      LJA=.TRUE.
      LIA=.FALSE.
      SGN=-1
      GO TO 9

      ENTRY DBSIA(X,A,NMAX,ND,B)
      LJA=.FALSE.
      LIA=.TRUE.
      SGN=1

    9 LER=.FALSE.
      IF(X .LE. 0) THEN
       WRITE(ERRTXT,101) X
       IF(LJA) CALL MTLPRT(NAMEJ,'C343.1',ERRTXT)
       IF(LIA) CALL MTLPRT(NAMEI,'C343.1',ERRTXT)
       LER=.TRUE.
      ELSEIF(.NOT.(0 .LE. A .AND. A .LT. 1)) THEN
       WRITE(ERRTXT,102) A
       IF(LJA) CALL MTLPRT(NAMEJ,'C343.2',ERRTXT)
       IF(LIA) CALL MTLPRT(NAMEI,'C343.2',ERRTXT)
       LER=.TRUE.
      ELSEIF(ABS(NMAX) .GT. 100) THEN
       WRITE(ERRTXT,103) NMAX
       IF(LJA) CALL MTLPRT(NAMEJ,'C343.3',ERRTXT)
       IF(LIA) CALL MTLPRT(NAMEI,'C343.3',ERRTXT)
       LER=.TRUE.
      END IF
      IF(LER) RETURN
      EPS=HF*Z10**(-ND)
      NMX=ABS(NMAX)
      IF(NMAX .LE. 0) NMX=1
      DO 5 N = 0,NMX
      RR(N)=0
    5 BA(N)=0
      D=TC(8)*ND+TC(9)
      SX=X
      Q=0
      IF(NMX .GT. 0) THEN
       V=0.5*D/NMX
       IF(V .LE. 10) THEN
        T=TC(1)
        DO 6 I = 2,6
    6   T=V*T+TC(I)
       ELSE
        U=LOG(V)-TC(7)
        T=V/(U*(1+(TC(7)-LOG(U))/(1+U)))
       ENDIF
       Q=NMX*T
      ENDIF
      F=(HF*X)**A/DGAMMA(1+A)
      T=1
      V=TC(10)*D/SX
      IF(LIA) THEN
       F=EXP(X)*F
       V=V-TC(10)
      ENDIF
      IF(LJA .OR. LIA .AND. X .LT. D) THEN
       IF(V .LE. 10) THEN
        T=TC(1)
        DO 7 I = 2,6
    7   T=V*T+TC(I)
       ELSE
        U=LOG(V)-TC(7)
        T=V/(U*(1+(TC(7)-LOG(U))/(1+U)))
       ENDIF
      ENDIF
      NU=1+MAX(Q,TC(11)*SX*T)

      MU=-1
    2 MU=MU+1
      AL=1
      IF(LJA) THEN
       DO 3 N = 1,NU/2
       XN=N
    3  AL=AL*(XN+A)/(XN+1)
       R=0
       S=0
       LEV=.TRUE.
       DO 4 N = 2*(NU/2),1,-1
       XN=N
       XA=XN+A
       R=1/(2*XA/X-R)
       IF(N .LE. NMX) RR(N-1)=R
       IF(LEV) THEN
        AL=AL*(XN+2)/(XA+A)
        S=R*(AL*XA+S)
       ELSE
        S=R*S
       ENDIF
       LEV=.NOT.LEV
    4  CONTINUE
      ELSE
       DO 23 N = 1,NU
       XN=N
   23  AL=AL*(XN+2*A)/(XN+1)
       R=0
       S=0
       DO 24 N = NU,1,-1
       XN=N
       XA=XN+A
       XA2=XA+XA
       R=1/(XA2/X+R)
       IF(N .LE. NMX) RR(N-1)=R
       AL=AL*(XN+1)/(XA+A)
       S=R*(XA2*AL+S)
   24  CONTINUE
      ENDIF
      B(0)=F/(1+S)
      DO 10 N = 0,NMX-1
   10 B(N+1)=RR(N)*B(N)
      DO 11 N = 0,NMX
      IF(ABS(B(N)-BA(N)) .GT. EPS*ABS(B(N))) THEN
       DO 12 M = 0,NMX
   12  BA(M)=B(M)
       NU=NU+5
       IF(MU .LE. 50) GO TO 2
       WRITE(ERRTXT,104) X,A
       IF(LJA) CALL MTLPRT(NAMEJ,'C343.4',ERRTXT)
       IF(LIA) CALL MTLPRT(NAMEI,'C343.4',ERRTXT)
       RETURN
      ENDIF
   11 CONTINUE
      IF(NMAX .LT. 0) THEN
       AL=2/X
       B(1)=AL*A*B(0)+SGN*B(1)
       DO 13 N = 1,-NMAX-1
   13  B(N+1)=AL*(A-N)*B(N)+SGN*B(N-1)
      ENDIF
      RETURN
  101 FORMAT('ILLEGAL ARGUMENT X = ',1P,D15.8)
  102 FORMAT('ILLEGAL ORDER A = ',1P,D15.8)
  103 FORMAT('ILLEGAL NMAX = ',I5)
  104 FORMAT('NO CONVERGENCE FOR X = ',1P,D15.8,' A = ',D15.8,
     1       ' TRY SMALLER ND')
      END
CDECK  ID>, CBSJA.  
      SUBROUTINE CBSJA(Z,A,NMAX,ND,CB)
      COMPLEX Z,CB(0:*)
      COMPLEX*16
     + V(0:100),W
      DOUBLE PRECISION
     + D
      SROUND(D)=D+(D-SNGL(D))
      W=Z
      CALL WBSJA(W,DBLE(A),NMAX,ND,V)
      DO 1 N = 0,NMAX
    1 CB(N)=CMPLX(SROUND(DREAL(V(N))),SROUND(DIMAG(V(N))))
      RETURN
      END
CDECK  ID>, CBSJA64.
      SUBROUTINE WBSJA(Z,A,NMAX,ND,CB)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMPLEX*16
     +    Z,ZA,CB,I,CBA,RR,F,C,S,R,GCONJG,ZZ
      REAL R0,D,T,Q,U,V,TC(11)
      CHARACTER*80 ERRTXT
      CHARACTER NAME*(*)
      PARAMETER (NAME = 'CBSJA/WBSJA')
      LOGICAL LER
      DIMENSION CB(0:*),CBA(0:100),RR(0:100)


      PARAMETER (I = (0D0,1D0))
      PARAMETER (Z0 = 0, Z1 = 1, HF = Z1/2, Z10 = 10)

      DATA TC / 5.7941 E-5,-1.76148E-3, 2.08645E-2,-1.29013E-1,
     1          8.5777 E-1, 1.0125 E+0, 7.75   E-1, 2.3026 E+0,
     2          1.3863 E+0, 7.3576 E-1, 1.3591 E+0/

      GCONJG(ZZ)=DCONJG(ZZ)
      X=Z
      Y=-I*Z
      LER=.FALSE.
      IF(X .LE. 0 .AND. Y .EQ. 0) THEN
       WRITE(ERRTXT,101) Z
       CALL MTLPRT(NAME,'C344.1',ERRTXT)
       LER=.TRUE.
      ELSEIF(.NOT.(0 .LE. A .AND. A .LT. 1)) THEN
       WRITE(ERRTXT,102) A
       CALL MTLPRT(NAME,'C344.2',ERRTXT)
       LER=.TRUE.
      ELSEIF(.NOT.(0 .LE. NMAX .AND. NMAX .LE. 100)) THEN
       WRITE(ERRTXT,103) NMAX
       CALL MTLPRT(NAME,'C344.3',ERRTXT)
       LER=.TRUE.
      END IF
      IF(LER) RETURN
      AZ=ABS(Z)
      YA=ABS(Y)
      ZA=X+I*YA
      EPS=HF*Z10**(-ND)
      DO 5 N = 0,NMAX
      RR(N)=0
    5 CBA(N)=0
      F=EXP(YA+I*(A*ATAN2(YA,X)-X))*(HF*AZ)**A/DGAMMA(1+A)
      D=TC(8)*ND+TC(9)
      Q=0
      R0=AZ
      IF(NMAX .GT. 0) THEN
       V=0.5*D/NMAX
       IF(V .LE. 10) THEN
        T=TC(1)
        DO 6 J = 2,6
    6   T=V*T+TC(J)
       ELSE
        U=LOG(V)-TC(7)
        T=V/(U*(1+(TC(7)-LOG(U))/(1+U)))
       END IF
       Q=NMAX*T
      END IF
      T=1
      IF(YA .LT. D) THEN
       V=TC(10)*(D-YA)/R0
       IF(V .LE. 10) THEN
        T=TC(1)
        DO 7 J = 2,6
    7   T=V*T+TC(J)
       ELSE
        U=LOG(V)-TC(7)
        T=V/(U*(1+(TC(7)-LOG(U))/(1+U)))
       END IF
      END IF
      NU=1+MAX(Q,TC(11)*R0*T)

      A2=A+A
      MU=-1
    2 MU=MU+1
      AL=1
      DO 3 N = 1,NU
      XN=N
    3 AL=AL*(XN+A2)/(XN+1)
      C=(-I)**NU
      R=0
      S=0
      DO 4 N = NU,1,-1
      XN=N
      A2N=2*(A+XN)
      R=ZA/(A2N-ZA*R)
      IF(N .LE. NMAX) RR(N-1)=R
      AL=AL*(XN+1)/(XN+A2)
      S=R*(A2N*AL*C+S)
    4 C=I*C
      CB(0)=F/(1+S)
      DO 10 N = 0,NMAX-1
   10 CB(N+1)=RR(N)*CB(N)
      IF(Y .LT. 0) THEN
       DO 11 N = 0,NMAX
   11  CB(N)=GCONJG(CB(N))
      END IF
      DO 12 N = 0,NMAX
      IF(ABS(CB(N)-CBA(N)) .GT. EPS*ABS(CB(N))) THEN
       DO 13 M = 0,NMAX
   13  CBA(M)=CB(M)
       NU=NU+5
       IF(MU .LE. 50) GO TO 2
       WRITE(ERRTXT,104) Z,A
       CALL MTLPRT(NAME,'C344.4',ERRTXT)
       RETURN
      END IF
   12 CONTINUE
      RETURN
  101 FORMAT('ILLEGAL ARGUMENT Z = ',1P,2D15.8)
  102 FORMAT('ILLEGAL ORDER A = ',1P,D15.8)
  103 FORMAT('ILLEGAL NMAX = ',I5)
  104 FORMAT('NO CONVERGENCE, Z = ',1P,2D13.6,' A = ',D13.6,
     1       ' TRY SMALLER ND')
      END
CDECK  ID>, BZEJY.  
      SUBROUTINE BZEJY(A,N,MODE,REL,X)
      DOUBLE PRECISION
     +      DX,D
      DIMENSION X(*),DX(200)

      SROUND(D)=D+(D-SNGL(D))
      CALL DBZEJY(DBLE(A),N,MODE,DBLE(REL),DX)
      DO 1 I = 1,N
    1 X(I)=SROUND(DX(I))
      RETURN
      END
CDECK  ID>, BZEJY64.
      SUBROUTINE DBZEJY(A,N,MODE,REL,X)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C     Computes the first n positive (in the case Jo'(x) the first n
C     non-negative) zeros of the Bessel functions
C               Ja(x), Ya(x), Ja'(x), Ya'(x),
C     where a >= 0 and ' = d/dx.
C
C     Based on Algol procedures published in
C
C     N.M. TEMME, An algorithm with Algol 60 program for the compu-
C     tation of the zeros of ordinary Bessel functions and those of
C     their derivatives, J. Comput. Phys. 32 (1979) 270-279, and
C
C     N.M. TEMME, On the numerical evaluation of the ordinary Bessel
C     function of the second kind, J. Comput. Phys. 21 (1976) 343-350.

      DIMENSION X(*),FCO(4),ICO(4),H(13)
      CHARACTER NAME*(*)
      CHARACTER*80 ERRTXT
      PARAMETER (NAME = 'BZEJY/DBZEJY')

      PARAMETER (Z1 = 1, Z2 = 2, Z5 = 5, Z6 = 6, Z7 = 7)
      PARAMETER (C1 = Z5/48, C2 = -Z5/36, C3 = -Z7/48)
      PARAMETER (C4 = 5*Z7/288, C5 = Z1/64, C6 = Z6/5, C7 = 3*Z6/7)
      PARAMETER (E1 = Z1/3, E2 = Z2/3, HALF = Z1/2)
      PARAMETER (PI = 3.14159 26535 89793 24D0)
      PARAMETER (PIH = PI/2, PI1 = 3*PI/8)

      DATA FCO /-2.33811,-1.17371,-1.01879,-2.29444/, ICO /1,3,3,1/

      IF(N .LE. 0) RETURN
      IF(A .LT. 0) THEN
       WRITE(ERRTXT,101) A
       CALL MTLPRT(NAME,'C345.1',ERRTXT)
       RETURN
      ENDIF
      NA=NINT(A)
      A0=A-NA
      H(1)=A**2
      H(2)=4*H(1)
      H(3)=H(2)**2
      H(4)=H(3)+H(3)
      H(5)=12*A+6
      H(6)=H(5)-4
      H(7)=3*A-8
      H(8)=HALF*(A-HALF*ICO(MODE))
      H(9)=COS(A0*PI)/(PI*REL)
      H(10)=PIH*(A+HALF)
      H(11)=HALF+A0
      H(12)=H(11)*(HALF-A0)
      H(13)=1
      IF(A .GE. 3) H(13)=A**(-E2)
      P1=0
      Q1=0
      IF(MODE .LT. 3) THEN
       IF(N .GE. H(7)) THEN
        P=7*H(2)-31
        PP=H(2)-1
        IF(1+P .NE. P) THEN
         P1=PP*((1012*H(2)-14888)*H(2)+71476)/(15*P)
         Q1=((664*H(2)-7856)*H(2)+30232)/(5*P)
        ENDIF
       ENDIF
       P2=C1
       Q2=C2
       R2=C6
      ELSE
       IF(N .GE. H(7)) THEN
        P=(7*H(2)+82)*H(2)-9
        PP=H(2)+3
        IF(1+P .NE. P) THEN
         P1=((((1012*H(2)+32816)*H(2)-55496)*H(2)-104400)*H(2)+
     1         253044)/(15*P)
         Q1=(((664*H(2)+16600)*H(2)-24312)*H(2)+28296)/(5*P)
        ENDIF
       ENDIF
       P2=C3
       Q2=C4
       R2=C7
      ENDIF
      X(1)=0
      N0=1
      IF(A .EQ. 0 .AND. MODE .EQ. 3) N0=2

      DO 1 L = N0,N
      IF(L .GE. H(7)) THEN
       B=(L+H(8))*PI
       C=C5/B**2
       X0=B-(PP-P1*C)/(8*B*(1-Q1*C))
      ELSE
       IF(L .EQ. 1) THEN
        X0=FCO(MODE)
       ELSE
        X0=PI1*(4*L-ICO(MODE))
        V=1/X0**2
        X0=-X0**E2*(1+V*(P2+Q2*V))
       ENDIF
       U=H(13)*X0
       Y=E2*SQRT(ABS(U)**3)

       IF(Y .LT. 1) THEN
        G0=(3*Y)**E1
        G1=G0**2
        G0=G0*(1-G1*(210+G1*(G1+G1-27))/1575)
       ELSE
        G0=1/(Y+PIH)
        G1=G0**2
        G0=PIH-G0*(1+G1*(2310+G1*(3003+G1*(4818+G1*
     1          (8591+G1*16328))))/3465)
       ENDIF
       G2=Y+G0
       G1=G2**2
       G=(G0-ATAN(G2))/G1
       W=1/COS(G0-(1+G1)*(1+G/G2)*G)
       G=1/(1-W**2)
       C=SQRT(U*G)
       X0=W*(A-P2*C*(1/U-C*(G+G-R2))/(A*U))
      ENDIF

      DO 2 J = 1,5
      XX=X0**2
      AX=H(1)-XX

      B=X0+X0
      E=(H(9)*X0)**2
      P=1
      Q=-X0
      S=1+XX
      R=S
      DO 3 K = 2,500
      IF(R*(K**2) .GE. E) GO TO 9
      RK=Z1/(K+1)
      D=((K-1)+H(12)/K)/S
      P=RK*((K+K)-P*D)
      Q=RK*(Q*D-B)
      S=P**2+Q**2
      R=R*S
    3 CONTINUE
    9 G=1/S
      P=G*P
      F=P
      Q=-G*Q
      G=Q
      DO 4 M = K+1,2,-1
      R=M*(2-P)-2
      S=B+M*Q
      D=((M-2)+H(12)/(M-1))/(R**2+S**2)
      P=D*R
      Q=D*S
      E=F+1
      F=P*E-G*Q
      G=Q*E+P*G
    4 CONTINUE
      F=F+1
      D=1/(F**2+G**2)
      PA=F*D
      QA=-G*D
      D=H(11)-P
      Q=Q+X0
      RX=1/X0
      PA1=RX*(PA*Q-QA*D)
      QA1=RX*(QA*Q+PA*D)
      XR=RX+RX
      B=(1+A0)*XR
      DO 5 M = 1,NA
      P0=PA-QA1*B
      Q0=QA+PA1*B
      PA=PA1
      PA1=P0
      QA=QA1
      QA1=Q0
      B=B+XR
    5 CONTINUE

      SX=SIN(X0-H(10))
      CX=COS(X0-H(10))
      GO TO (11,12,13,14), MODE
   11 R0=(PA*CX-QA*SX)/(PA1*SX+QA1*CX)
      V=R0/(H(5)*X0)
      W=R0*(1+V*(1-4*AX))/(1+V*(4*(XX-H(2))-H(6)))
      GO TO 10
   12 R0=(PA*SX+QA*CX)/(QA1*SX-PA1*CX)
      V=R0/(H(5)*X0)
      W=R0*(1+V*(1-4*AX))/(1+V*(4*(XX-H(2))-H(6)))
      GO TO 10
   13 R0=A/X0-(PA1*SX+QA1*CX)/(PA*CX-QA*SX)
      GO TO 15
   14 R0=A/X0-(QA1*SX-PA1*CX)/(PA*SX+QA*CX)
   15 V=E2*R0*X0*AX/(H(1)+XX)
      W=C5/AX**3
      W=-XX*R0*(1+V*(1-W*(H(3)-XX*(40*H(2)+48*XX))))/
     1     (AX*(1+V*(1+W*(H(4)+XX*(64*H(2)+96*XX)))))
   10 X0=X0+W
      IF(ABS(W) .LE. REL*X0) GO TO 6
    2 CONTINUE
    6 X(L)=X0
    1 CONTINUE
      RETURN
  101 FORMAT('NEGATIVE INDEX A = ',1P,D15.8)
      END
CDECK  ID>, RELI1.  
      FUNCTION RELI1(X,AKP)
      IMPLICIT DOUBLE PRECISION (D)

      SROUND(D)=D+(D-SNGL(D))
      RELI1=SROUND(DELI1(DBLE(X),DBLE(AKP)))
      RETURN

      ENTRY RELI2(X,AKP,A,B,MODE)
      RELI2=SROUND(DELI2(DBLE(X),DBLE(AKP),DBLE(A),DBLE(B),MODE))
      RETURN

      ENTRY RELI3(X,AKP,P)
      RELI3=SROUND(DELI3(DBLE(X),DBLE(AKP),DBLE(P)))
      RETURN
      END
CDECK  ID>, RELI164.
      FUNCTION DELI1(X,AKP)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C
C     Translation of Algol procedure el1(x,kc) in
C      R. BULIRSCH Numerical Calculation of Elliptic Integrals and
C      Elliptic Functions,  Numer. Math. 7 (1965) 78-90
C
      PARAMETER (ID = 16)
      PARAMETER (PI = 3.14159 26535 89793 24D0)
      PARAMETER (Z10 = 10)
      PARAMETER (CA = Z10**(-ID/2), CB = Z10**(-(ID+2)))

      IF(X .EQ. 0) THEN
       H=0
      ELSEIF(AKP .EQ. 0) THEN
       H=DASINH(X)
      ELSE
       Y=ABS(1/X)
       YKP=ABS(AKP)
       XM=1
       L=0
    1  E=XM*YKP
       G=XM
       XM=YKP+XM
       Y=-E/Y+Y
       IF(Y .EQ. 0) Y=SQRT(E)*CB
       IF(ABS(G-YKP) .GT. CA*G) THEN
        YKP=2*SQRT(E)
        L=2*L
        IF(Y .LT. 0) L=L+1
        GO TO 1
       ENDIF
       IF(Y .LT. 0) L=L+1
       E=(ATAN(XM/Y)+PI*L)/XM
       IF(X .LT. 0) E=-E
       H=E
      ENDIF
      DELI1=H
      RETURN
      END
CDECK  ID>, RELI264.
      FUNCTION DELI2(X,AKP,A,B,MODE)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      CHARACTER*(*) NAME
      PARAMETER(NAME='RELI2/DELI2')
C
C     Translation of Algol procedure el2(x,kc,a,b) in
C      R. BULIRSCH Numerical Calculation of Elliptic Integrals and
C      Elliptic Functions,  Numer. Math. 7 (1965) 78-90,
C      extended for (k sub c)**2 < 0  (MODE = -1)
C
      PARAMETER (ID = 16)
      PARAMETER (PI = 3.14159 26535 89793 24D0)
      PARAMETER (Z1 = 1, Z10 = 10, HF = Z1/2)
      PARAMETER (CA = Z10**(-ID/2), CB = Z10**(-(ID+2)))

      CHARACTER*80 ERRTXT

      IF(X .EQ. 0 .OR. AKP .EQ. 0) THEN
       H=B*DASINH(X)+(A-B)*X/SQRT(1+X**2)
      ELSE
       IF(MODE .EQ. 1) THEN
        XX=X
        BKP=AKP
        AA=A
        BB=B
       ELSEIF(MODE .EQ. -1) THEN
        W=1-(AKP*X)**2
        IF(W .GT. 0) THEN
         W1=1/SQRT(1+AKP**2)
         XX=X/(W1*SQRT(W))
         BKP=AKP*W1
         AA=A*W1
         BB=(B+A*AKP**2)*W1**3
        ELSE
         H=0
         WRITE(ERRTXT,101) X,AKP
         CALL MTLPRT(NAME,'C346.1',ERRTXT)
         GO TO 9
        ENDIF
       ELSE
        H=0
        WRITE(ERRTXT,102) MODE
        CALL MTLPRT(NAME,'C346.2',ERRTXT)
        GO TO 9
       ENDIF
       C=XX**2
       D=1+C
       PP=SQRT((1+BKP**2*C)/D)
       D=XX/D
       C=D/(2*PP)
       Z=AA-BB
       XI=AA
       AA=HF*(AA+BB)
       Y=ABS(1/XX)
       F=0
       L=0
       XM=1
       YKP=ABS(BKP)
    1  BB=XI*YKP+BB
       E=XM*YKP
       G=E/PP
       D=F*G+D
       F=C
       XI=AA
       PP=G+PP
       C=HF*(D/PP+C)
       G=XM
       XM=YKP+XM
       AA=HF*(BB/XM+AA)
       Y=Y-E/Y
       IF(Y .EQ. 0) Y=SQRT(E)*CB
       IF(ABS(G-YKP) .GT. CA*G) THEN
        YKP=2*SQRT(E)
        L=2*L
        IF(Y .LT. 0) L=L+1
        GO TO 1
       ENDIF
       IF(Y .LT. 0) L=L+1
       E=(ATAN(XM/Y)+PI*L)*AA/XM
       IF(XX .LT. 0) E=-E
       H=E+C*Z
      ENDIF
    9 DELI2=H
      RETURN
  101 FORMAT('X = ',1P,D15.8,' AKP = ',D15.8,' ILLEGAL',
     1       '[(AKP * X)**2 >= 1]')
  102 FORMAT('MODE = ',I5,' ILLEGAL')
      END
CDECK  ID>, RELI364.
      FUNCTION DELI3(X,AKP,P)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      CHARACTER*(*) NAME
      PARAMETER(NAME='RELI3/DELI3')
C
C     Translation of Algol procedure el3(x,kc,p) in
C      R. BULIRSCH Numerical Calculation of Elliptic Integrals and
C      Elliptic Functions III.,  Numer. Math. 13 (1969) 305-315
C
      LOGICAL LBO,LBK

      PARAMETER (ID = 16, IB = 4)
      PARAMETER (PI  = 3.14159 26535 89793 24D0)
      PARAMETER (AL2 = 0.69314 71805 59945 31D0)
      PARAMETER (ALB = IB*AL2, RLB = 1/ALB)
      PARAMETER (Z1 = 1, Z10 = 10, HF = Z1/2, C1 = Z1/10)
      PARAMETER (ND = ID-2, CA = Z10**(-ID/2), CB = Z10**(-(ID+2)))
      PARAMETER (ZD = HF/(ND+1))

      CHARACTER*80 ERRTXT

      DIMENSION RA(2:ND),RB(2:ND),RR(2:ND)

      DATA (RB(K),RA(K),K=2,ND)
     2/2.50000000000000000D-01, 7.50000000000000000D-01,
     3 1.66666666666666667D-01, 8.33333333333333333D-01,
     4 1.25000000000000000D-01, 8.75000000000000000D-01,
     5 1.00000000000000000D-01, 9.00000000000000000D-01,
     6 8.33333333333333333D-02, 9.16666666666666667D-01,
     7 7.14285714285714286D-02, 9.28571428571428571D-01,
     8 6.25000000000000000D-02, 9.37500000000000000D-01,
     9 5.55555555555555556D-02, 9.44444444444444445D-01,
     A 5.00000000000000000D-02, 9.50000000000000000D-01,
     B 4.54545454545454545D-02, 9.54545454545454545D-01,
     C 4.16666666666666667D-02, 9.58333333333333333D-01,
     D 3.84615384615384615D-02, 9.61538461538461538D-01,
     E 3.57142857142857143D-02, 9.64285714285714286D-01/

      IF(X .EQ. 0) THEN
       H=0
       GO TO 9
      ENDIF
      HH=X**2
      F=P*HH
      S=AKP
      IF(S .EQ. 0) S=CA/(1+ABS(X))
      T=S**2
      PM=HF*T
      E=HH*T
      Z=ABS(F)
      R=ABS(P)
      H1=HH+1
      IF(E .LT. C1 .AND. Z .LT. C1 .AND. T .LT. 1 .AND. R .LT. 1) THEN
       S=P+PM
       DO 1 K = 2,ND
       RR(K)=S
       PM=PM*T*RA(K)
    1  S=S*P+PM
       U=S*ZD
       S=U
       LBO=.FALSE.
       DO 2 K = ND,2,-1
       U=U+(RR(K)-U)*RB(K)
       LBO=.NOT.LBO
       V=U
       IF(LBO) V=-U
    2  S=S*HH+V
       IF(LBO) S=-S
       U=HF*(U+1)
       H=(U-S*H1)*SQRT(H1)*X+U*DASINH(X)
      ELSE
       W=1+F
       IF(W .EQ. 0) THEN
        H=0
        WRITE(ERRTXT,103) X,P
        CALL MTLPRT(NAME,'C346.3',ERRTXT)
        GO TO 9
       ENDIF
       PP=P
       IF(PP .EQ. 0) PP=CB/HH
       S=ABS(S)
       Y=ABS(X)
       G=PP-1
       IF(G .EQ. 0) G=CB
       F=PP-T
       IF(F .EQ. 0) F=CB*T
       AM=1-T
       AP=1+E
       R=PP*H1
       FA=G/(F*PP)
       LBO=FA .GT. 0
       FA=ABS(FA)
       PZ=ABS(G*F)
       DE=SQRT(PZ)
       Q=SQRT(ABS(PP))
       PM=PP-MIN(PM,HF)
       IF(PM .GE. 0) THEN
        U=SQRT(R*AP)
        V=Y*DE
        IF(G .LT. 0) V=-V
        D=1/Q
        C=1
       ELSE
        U=SQRT(H1*AP*PZ)
        YE=Y*Q
        V=AM*YE
        Q=-DE/G
        D=-AM/DE
        C=0
        PZ=AP-R
       ENDIF
       IF(LBO) THEN
        R=V/U
        Z=1
        K=1
        IF(PM .LT. 0) THEN
         H1=Y*SQRT(H1/(AP*FA))
         H1=1/H1-H1
         Z=H1-2*R
         R=2+R*H1
         IF(R .EQ. 0) R=CB
         IF(Z .EQ. 0) Z=H1*CB
         R=R/Z
         Z=R
         W=PZ
        ENDIF
        U=U/W
        V=V/W
       ELSE
        T=U+ABS(V)
        LBK=.TRUE.
        IF(PP .LT. 0) THEN
         DE=V/PZ
         YE=2*U*YE
         U=T/PZ
         V=-(F+G*E)/T
         T=PZ*ABS(W)
         Z=(HH*R*F-G*AP+YE)/T
         YE=YE/T
        ELSE
         DE=V/W
         YE=0
         U=(E+PP)/T
         V=T/W
         Z=1
        ENDIF
        IF(S .GT. 1) THEN
         H1=U
         U=V
         V=H1
        ENDIF
       ENDIF
       Y=1/Y
       E=S
       T=1
       N=1
       L=0
       M=0
    3  Y=Y-E/Y
       IF(Y .EQ. 0) Y =SQRT(E)*CB
       F=C
       C=D/Q+C
       G=E/Q
       D=2*(F*G+D)
       Q=G+Q
       G=T
       T=S+T
       N=2*N
       M=2*M
       IF(LBO) THEN
        IF(Z .LT. 0) M=K+M
        K=0
        IF(R .GT. 0) K=1
        IF(R .LT. 0) K=-1
        H1=E/(U**2+V**2)
        U=U*(1+H1)
        V=V*(1-H1)
       ELSE
        R=U/V
        H1=Z*R
        Z=H1*Z
        HH=E/V
        IF(LBK) THEN
         DE=DE/U
         YE=YE*(H1+1/H1)+DE*(1+R)
         DE=DE*(U-HH)
         LBK=ABS(YE) .LT. 1
        ELSE
         A=LOG(Z)
         K=RLB*A
         IF(Z .GE. 1) K=K+1
         Z=EXP(A-K*ALB)
         M=M+K
        ENDIF
       ENDIF
       IF(ABS(G-S) .GT. CA*G) THEN
        IF(LBO) THEN
         G=HF*(1/R-R)
         HH=U+V*G
         H1=G*U-V
         IF(HH .EQ. 0) HH=U*CB
         IF(H1 .EQ. 0) H1=V*CB
         Z=R*H1
         R=HH/H1
        ELSE
         U=U+E/U
         V=V+HH
        ENDIF
        S=2*SQRT(E)
        E=S*T
        L=2*L
        IF(Y .LT. 0) L=L+1
        GO TO 3
       ENDIF
       IF(Y .LT. 0) L=L+1
       E=(ATAN(T/Y)+PI*L)*(C*T+D)/(T*(T+Q))
       IF(LBO) THEN
        H1=V/(T+U)
        Z=1-R*H1
        H1=R+H1
        IF(Z .EQ. 0) Z=CB
        IF(Z .LT. 0) THEN
         IF(H1 .GT. 0) M=M+1
         IF(H1 .LT. 0) M=M-1
        ENDIF
        S=ATAN(H1/Z)+M*PI
       ELSE
        IF(LBK) THEN
         S=HF*DASINH(YE)
        ELSE
         S=HF*(LOG(Z)+M*ALB)
        ENDIF
       ENDIF
       H=(E+SQRT(FA)*S)/N
       IF(X .LT. 0) H=-H
      ENDIF
    9 DELI3=H
      RETURN
  103 FORMAT('FUNCTION SINGULAR FOR ',1P,
     1 'X = ',D15.8,3X,'P = ',D15.8,4X,'(P*X**2 = -1)')
      END
CDECK  ID>, RELI1C. 
      FUNCTION RELI1C(AKP)
      IMPLICIT DOUBLE PRECISION (D)

      SROUND(D)=D+(D-SNGL(D))
      RELI1C=SROUND(DELI1C(DBLE(AKP)))
      RETURN

      ENTRY RELI2C(AKP,A,B)
      RELI2C=SROUND(DELI2C(DBLE(AKP),DBLE(A),DBLE(B)))
      RETURN

      ENTRY RELI3C(AKP,AK2,P)
      RELI3C=SROUND(DELI3C(DBLE(AKP),DBLE(AK2),DBLE(P)))
      RETURN

      ENTRY RELIGC(AKP,P,A,B)
      RELIGC=SROUND(DELIGC(DBLE(AKP),DBLE(P),DBLE(A),DBLE(B)))
      RETURN

      ENTRY RELIKC(AK)
      ENTRY ELLICK(AK)
      RELIKC=SROUND(DELIKC(DBLE(AK)))
      RETURN

      ENTRY RELIEC(AK)
      ENTRY ELLICE(AK)
      RELIEC=SROUND(DELIEC(DBLE(AK)))
      RETURN
      END
CDECK  ID>, RELI1C64.   
      FUNCTION DELI1C(AKP)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      CHARACTER*(*) NAME1,NAME2,NAME3
      PARAMETER(NAME1='RELI1C/DELI1C')
      PARAMETER(NAME2='RELI2C/DELI2C')
      PARAMETER(NAME3='RELI3C/DELI3C')
C
C     Translation of Algol procedures cel1(kc), cel2(kc,a,b) in
C      R. BULIRSCH Numerical Calculation of Elliptic Integrals and
C      Elliptic Functions,  Numer. Math. 7 (1965) 78-90
C     and of Algol procedure cel3(kc,m,p) in
C      R. BULIRSCH Numerical Calculation of Elliptic Integrals and
C      Elliptic Functions II.,  Numer. Math. 7 (1965) 353-354
C
      PARAMETER (ID = 16)
      PARAMETER (PI = 3.14159 26535 89793 24D0)
      PARAMETER (PIH = PI/2, PIQ = PI/4)
      PARAMETER (Z1 = 1, Z10 = 10, HF = Z1/2)
      PARAMETER (CA = Z10**(-ID/2))

      IF(AKP .EQ. 0) THEN
       H=0
       CALL MTLPRT(NAME1,'C347.1','AKP = 0')
      ELSE
       YKP=ABS(AKP)
       XM=1
    1  G=XM
       XM=YKP+XM
       IF(ABS(G-YKP) .GT. CA*G) THEN
        YKP=SQRT(G*YKP)
        XM=HF*XM
        GO TO 1
       ENDIF
       H=PI/XM
      ENDIF
      GO TO 9

      ENTRY DELI2C(AKP,A,B)

      IF(AKP .EQ. 0) THEN
       IF(B .EQ. 0) THEN
        H=A
       ELSE
        H=0
        CALL MTLPRT(NAME2,'C347.2','AKP = 0, B NE 0')
       ENDIF
      ELSE
       AA=A
       BB=B
       XM=1
       C=AA
       AA=BB+AA
       YKP=ABS(AKP)
    2  BB=2*(C*YKP+BB)
       C=AA
       XM0=XM
       XM=YKP+XM
       AA=BB/XM+AA
       IF(ABS(XM0-YKP) .GT. CA*XM0) THEN
        YKP=2*SQRT(YKP*XM0)
        GO TO 2
       ENDIF
       H=PIQ*AA/XM
      ENDIF
      GO TO 9

      ENTRY DELI3C(AKP,AK2,P)

      IF(AKP*P .EQ. 0) THEN
       H=0
       CALL MTLPRT(NAME3,'C347.3','AKP * P = 0')
      ELSE
       YKP=ABS(AKP)
       E=YKP
       AM0=1
       PP=P
       IF(PP .GT. 0) THEN
        C=1
        PP=SQRT(PP)
        D=1/PP
       ELSE
        G=1-PP
        F=YKP**2-PP
        PP=SQRT(F/G)
        D=-AK2/(G*PP)
        C=0
       ENDIF
    3  F=C
       C=D/PP+C
       G=E/PP
       D=2*(F*G+D)
       PP=G+PP
       G=AM0
       AM0=YKP+AM0
       IF(ABS(G-YKP) .GT. CA*G) THEN
        YKP=2*SQRT(E)
        E=YKP*AM0
        GO TO 3
       ENDIF
       H=PIH*(C*AM0+D)/(AM0*(AM0+PP))
      ENDIF
    9 DELI1C=H
      RETURN
      END
CDECK  ID>, RELIGC64.   
      FUNCTION DELIGC(AKP,P,A,B)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      CHARACTER*(*) NAME
      PARAMETER(NAME='RELIGC/DELIGC')
C
C     Translation of Algol procedure cel(kc,p,a,b) in
C      R. BULIRSCH Numerical Calculation of Elliptic Integrals and
C      Elliptic Functions III.,  Numer. Math. 13 (1969) 305-315
C
      PARAMETER (ID = 16)
      PARAMETER (PI = 3.14159 26535 89793 24D0, PIH = PI/2)
      PARAMETER (Z10 = 10)
      PARAMETER (CA = Z10**(-ID/2))

      IF(AKP .EQ. 0) THEN
       H=0
       CALL MTLPRT(NAME,'C347.4','AKP = 0')
      ELSE
       PP=P
       AA=A
       BB=B
       YKP=ABS(AKP)
       E=YKP
       XM=1
       IF(PP .GT. 0) THEN
        PP=SQRT(PP)
        BB=BB/PP
       ELSE
        F=YKP**2
        Q=1-F
        G=1-PP
        F=F-PP
        Q=(BB-AA*PP)*Q
        PP=SQRT(F/G)
        AA=(AA-BB)/G
        BB=-Q/(G**2*PP)+AA*PP
       ENDIF
    1  F=AA
       AA=BB/PP+AA
       G=E/PP
       BB=2*(F*G+BB)
       PP=G+PP
       G=XM
       XM=YKP+XM
       IF(ABS(G-YKP) .GT. G*CA) THEN
        YKP=2*SQRT(E)
        E=YKP*XM
        GO TO 1
       ENDIF
       H=PIH*(AA*XM+BB)/(XM*(XM+PP))
      ENDIF
      DELIGC=H
      RETURN
      END
CDECK  ID>, RELIKC64.   
      FUNCTION DELIKC(AK)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      CHARACTER*(*) NAMEK,NAMEE
      PARAMETER(NAMEK='RELIKC/DELIKC',NAMEE='RELIEC/DELIEC')
      CHARACTER*80 ERRTXT
C
C     Based on
C      W.J. Cody, Chebyshev approximations for the complete elliptic
C      integrals K and E, Math. Comp. l9 (1965) 105-112
C
      DIMENSION A(8),B(8),P(8),Q(8)

      PARAMETER (Z1 = 1, HF = Z1/2, C = 1.38629 43611 19890 6D0)
      DATA A
     1/6.49984 43329 39018 0D-4, 6.69055 09906 89793 6D-3,
     2 1.38556 01247 15656 0D-2, 1.12089 18554 64409 2D-2,
     3 9.65875 79861 75311 3D-3, 1.49789 88178 70462 9D-2,
     4 3.08855 73486 75269 4D-2, 9.65735 90797 58901 8D-2/
      DATA B
     1/1.50491 81783 60188 3D-4, 3.18313 09927 86288 6D-3,
     2 1.41053 80776 15804 8D-2, 2.71898 61116 78825 0D-2,
     3 3.70683 98934 15542 2D-2, 4.88180 58565 40395 2D-2,
     4 7.03124 26464 62736 1D-2, 1.24999 99994 11792 3D-1/
      DATA P
     1/7.09809 64089 98722 9D-4, 7.33561 64974 29036 5D-3,
     2 1.53771 02528 55201 9D-2, 1.30341 46073 73143 2D-2,
     3 1.25105 92410 84464 4D-2, 2.18762 20647 18619 8D-2,
     4 5.68056 57874 69535 8D-2, 4.43147 18112 15580 6D-1/
      DATA Q
     1/1.64272 10797 04802 5D-4, 3.48386 79435 89649 2D-3,
     2 1.55251 29948 04072 1D-2, 3.03027 47728 41284 8D-2,
     3 4.23828 07456 94790 0D-2, 5.85828 39536 55902 4D-2,
     4 9.37499 20249 68011 3D-2, 2.49999 99993 61762 2D-1/

      ENTRY DELLIK(AK)

      U=AK**2
      IF(U .LT. 1) THEN
       Y=1-U
       PA=A(1)
       PB=B(1)
       DO 1 I = 2,8
       PA=PA*Y+A(I)
    1  PB=PB*Y+B(I)
       H=C+PA*Y-LOG(Y)*(HF+PB*Y)
      ELSE
       H=0
       WRITE(ERRTXT,105) AK
       CALL MTLPRT(NAMEK,'C347.5',ERRTXT)
      ENDIF
      GO TO 9

      ENTRY DELIEC(AK)
      ENTRY DELLIE(AK)

      U=AK**2
      IF(U .LT. 1) THEN
       Y=1-U
       PA=P(1)
       PB=Q(1)
       DO 2 I = 2,8
       PA=PA*Y+P(I)
    2  PB=PB*Y+Q(I)
       H=1+(PA-LOG(Y)*PB)*Y
      ELSE IF(U .EQ. 1) THEN
       H=1
      ELSE
       H=0
       WRITE(ERRTXT,105) AK
       CALL MTLPRT(NAMEE,'C347.6',ERRTXT)
      ENDIF
    9 DELIKC=H
      RETURN
  105 FORMAT('ILLEGAL  AK = ',1P,D15.8)
      END
CDECK  ID>, CELINT64.   
      FUNCTION WELINT(Z,AKC,A,B)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      CHARACTER*(*) NAME
      PARAMETER(NAME='CELINT/WELINT')
      COMPLEX*16 WELINT
C
C     Translation of Algol procedure elco2(x,y,kc,a,b,u,v) in
C      R. BULIRSCH Numerical Calculation of Elliptic Integrals and
C      Elliptic Functions,  Numer. Math. 7 (1965) 78-90
C
      COMPLEX*16
     + Z,I,W,C0
      DIMENSION D1(0:12),D2(0:12)

      PARAMETER (ID = 16)
      PARAMETER (I = (0D0,1D0))
      PARAMETER (Z1 = 1, Z10 = 10, HF = Z1/2)
      PARAMETER (CC = Z10**(-ID), C0 = I-I)

      CHARACTER*80 ERRTXT

      X=Z
      Y=-I*Z
      IF(Z .EQ. C0 .OR. AKC .EQ. 0) THEN
       W=SQRT(1+Z**2)
       W=B*LOG(Z+W)+(A-B)*Z/W
      ELSEIF(X .LT. 0) THEN
       W=0
       WRITE(ERRTXT,101) X
       CALL MTLPRT(NAME,'C348.1',ERRTXT)
      ELSE
       AA=A
       BB=B
       SY=SIGN(Z1,Y)
       Y=ABS(Y)
       C=X**2-Y**2
       E2=2*X*Y
       D=AKC**2
       XK=1-D
       E1=1+C
       F2=1/(E1**2+E2**2)
       F1=((1+D*C)*E1+D*E2**2)*F2
       F2=-2*XK*X*Y*F2
       DN1=SQRT(HF*(SQRT(F1**2+F2**2)+ABS(F1)))
       DN2=HF*F2/DN1
       IF(F1 .LT. 0) THEN
        F1=DN1
        DN1=-DN2
        DN2=-F1
       ENDIF
       IF(XK .LT. 0) THEN
        DN1=ABS(DN1)
        DN2=ABS(DN2)
       ENDIF
       C=1+DN1
       F1=E1*C-E2*DN2
       F2=E1*DN2+E2*C
       D2(0)=1/(F1**2+F2**2)
       D1(0)=(X*F1+Y*F2)*D2(0)
       D2(0)=(Y*F1-X*F2)*D2(0)
       H=AA-BB
       N=1
       XM=1
       F=1
       D=1
       YKC=ABS(AKC)
       E=AA
       AA=BB+AA
       L=4
    1  XM1=HF*(YKC+XM)
       XM2=XM1**2
       XK=F*XK/(4*XM2)
       BB=E*YKC+BB
       E=AA
       F2=1/(C**2+DN2**2)
       F1=((YKC+XM*DN1)*C+XM*DN2**2)*F2
       E1=F1/XM1
       E2=XK*DN2*F2
       DN1=SQRT(HF*(SQRT(E1**2+(2*E2)**2)+ABS(E1)))
       DN2=E2/DN1
       F1=DN1*X-DN2*Y
       F2=DN1*Y+DN2*X
       X=ABS(F1)
       Y=ABS(F2)
       AA=BB/XM1+AA
       L=2*L
       C=1+DN1
       D=HF*XK*D
       E1=1+(X**2-Y**2)*XM2
       E2=2*X*Y*XM2
       F1=C*E1-DN2*E2
       F2=C*E2+DN2*E1
       E1=D/(F1**2+F2**2)
       D1(N)=(X*F1+Y*F2)*E1
       D2(N)=(Y*F1-X*F2)*E1
       XK=XK**2
       IF(XK .GT. CC) THEN
        YKC=SQRT(XM*YKC)
        F=XM2
        XM=XM1
        N=N+1
        GO TO 1
       ENDIF
       F2=0
       F1=0
       DO 2 J = N,0,-1
       F1=D1(J)+F1
    2  F2=D2(J)+F2
       X=XM1*X
       Y=XM1*Y
       C=X**2+Y**2
       E2=1/(1+2*Y+C)
       E1=(1-C)*E2
       E2=2*X*E2
       D=AA/(XM1*L)
       W=D*ATAN2(E2,E1)+H*F1+I*SY*(H*F2-LOG(E1**2+E2**2)*HF*D)
      ENDIF
      WELINT=W
      RETURN
  101 FORMAT('RE(Z) = ',1P,D15.8,' < 0')
      END
CDECK  ID>, CELINT. 
      FUNCTION CELINT(Z,AKC,A,B)
C
      COMPLEX CELINT,Z
      COMPLEX*16 WELINT,W
      DOUBLE PRECISION D

      SROUND(D)=D+(D-SNGL(D))
      W=WELINT(DCMPLX(DBLE(REAL(Z)),DBLE(AIMAG(Z))),DBLE(AKC),DBLE(A),
     1                DBLE(B))
      CELINT=CMPLX(SROUND(DREAL(W)),SROUND(DIMAG(W)))
      RETURN
      END
CDECK  ID>, RTHETA. 
      FUNCTION RTHETA( K, X, Q )
      DOUBLE PRECISION D,DTHETA
C
C  RTHETA is set equal to the correctly rounded value of DTHETA.
C  (Version 9.04.1992)
C
C--Start.
      D = DTHETA( K, DBLE(X), DBLE(Q) )
      RTHETA = D + ( D - SNGL(D) )
      RETURN
      END
CDECK  ID>, RTHETA64.   
      FUNCTION DTHETA( K, X, Q )
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      CHARACTER*(*) NAME
      PARAMETER(NAME='RTHETA/DTHETA')
      PARAMETER ( TWO=2, HALF=1/TWO, FOURTH=HALF**2 )
      PARAMETER ( PI = 3.14159 26535 89793 24 D0, PISQ=PI**2 )
      PARAMETER ( IADIM = 20 )
      DIMENSION A1(0:IADIM), A3(0:IADIM)
C  Set NBITS = number of mantissa bits.
      PARAMETER ( NBITS = 56 )
C  Set QZ to the value specified in the comments.
      PARAMETER ( QZ = 0.7809 )
C
C  The following statements set various constants (see comments).
      PARAMETER ( ELOW = -0.693*NBITS )
      PARAMETER ( QZSQ = QZ**2 )
      PARAMETER ( C10 = QZSQ, C11 = 2*QZ*(1-QZ) )
      PARAMETER ( C30 = QZSQ**2, C31 = 2*QZSQ*(1-QZSQ) )
C
      CHARACTER*130 ERRTXT

      DATA  QPRV1A, QPRV1B, QPRV3A, QPRV3B / 4*-9999. /
      SAVE A1, A3, QPRV1A, QPRV1B, QPRV3A, QPRV3B, B3, R, COEFF
      SAVE N1, N3
C
C  *********************************************************************
C
C  function is set equal to the value of theta(K,pi*X,Q), where
C  theta(k,u,q) is the theta function with subscript k (=1,2,3,4)
C  as defined in "Handbook of Mathematical Functions", M.Abramowitz
C  & I.A. Stegun (eds.), Washington, 1964.  K=0 is accepted as equiv-
C  alent to K=4.
C
C  The constant QZ in the parameter statement should be set as follows:
C           QZ = exp( (pi**2)/log(eps/3) ),
C  where eps=2**(-NBITS).
C
C  The constants Cj0 and Cj1 (j=1,3) then have values such that the two
C  inequalities
C
C           0 .le. t .le. 1/2,
C           0 .le. q .le. cj0 + cj1*t,
C
C  define a region within which the theta function can be approximated
C  with relative error less than eps by using either one (k=1,2) or two
C  (k=3,4) terms of the transformed series.
C
C  The constant ELOW has a value such that 1-EXP(u) is equal to 1 to
C  machine accuracy if u.lt.ELOW.
C
C  NOTE.  The value of NBITS and the corresponding QZ do not have to be
C         set separately for each computer.  All that is required is
C         that the number of mantissa bits shall not be greater than
C         NBITS.  Too large a value of NBITS merely causes the program
C         to run somewhat slower for certain values of X and Q.
C
C  (Version 11.02.1992)
C
C  *********************************************************************
C
C--Start.  Check Q and select basic function theta1 or theta3.
      IF ( Q.LT.0 .OR. Q.GT.1 ) THEN
         WRITE(ERRTXT,101) K,X,Q
         CALL MTLPRT(NAME,'C349.1',ERRTXT)
         RESULT = 0
         GO TO 50
      ENDIF
      IF ( K.EQ.1 ) THEN
         T = X
         GO TO 10
      ELSEIF ( K.EQ.2 ) THEN
         T = HALF - ABS(X)
         GO TO 10
      ELSEIF ( K.EQ.3 ) THEN
         T = X
         GO TO 30
      ELSEIF ( K.EQ.4 .OR. K.EQ.0 ) THEN
         T = HALF - ABS(X)
         GO TO 30
      ELSE
         WRITE(ERRTXT,102) K,X,Q
         CALL MTLPRT(NAME,'C349.2',ERRTXT)
         RESULT = 0
         GO TO 50
      ENDIF
C----------------------------------------------------------------------
C
C--Basic function THETA1.
C
C  Reduce argument T to the interval (0,1/2).
   10 FSIGN = +1
      IF ( T.LT.0 ) FSIGN = -FSIGN
      T = ABS(T)
      TINT = AINT(T)
      IF ( MOD(TINT,TWO) .NE. 0 ) FSIGN = -FSIGN
      T = T - TINT
      IF ( T.GE.HALF ) THEN
         T = 1 - T
      ELSEIF( T.EQ.0 ) THEN
         RESULT = 0
         GO TO 50
      ENDIF
      IF ( Q .GT. C10+C11*T ) GO TO 14
C
C  Classical series.
C  (If Q has changed value, compute N1 and A1(j), j=0,1,...,N1)
      IF ( Q.NE.QPRV1A ) THEN
         AZERO = 2*SQRT(SQRT(Q))
         QSQ = Q**2
         P = -1
         ATEMP = 1
         DO 11 J = 0,IADIM
            A1(J) = AZERO*ATEMP
            N1 = J
            P = QSQ*P
            ATEMP = P*ATEMP
            IF ( 1-ABS(ATEMP) .EQ. 1 ) GO TO 12
   11    CONTINUE
   12    QPRV1A = Q
      ENDIF
C  (Compute the series using forwards recurrence for sines)
      S = SIN(PI*T)
      ALPHA = 2 - 4*(S**2)
      U = -S
      SUM = A1(0)*S
      DO 13 J = 1,N1
         V = U
         U = S
         S = ALPHA*U - V
         SUM = SUM + A1(J)*S
   13 CONTINUE
      RESULT = FSIGN*SUM
      GO TO 50
C
C  One-term sinh approximation.
   14 IF ( Q.EQ.1 ) THEN
         RESULT = 0
      IF ( T.EQ.HALF ) THEN
         WRITE(ERRTXT,103) K,X,Q
         CALL MTLPRT(NAME,'C349.3',ERRTXT)
      ENDIF
         GO TO 50
      ENDIF
C  (If Q has changed value, compute R and COEFF)
      IF ( Q.NE.QPRV1B ) THEN
         ABSLOG = ABS(LOG(Q))
         R = PISQ/ABSLOG
         COEFF = SQRT(PI/ABSLOG)
         QPRV1B = Q
      ENDIF
C  (Compute function)
      U = R*T
      IF ( U.LT.HALF ) THEN
         E = -R*( T**2 + FOURTH )
         ETERM = EXP(E)
         IF ( ETERM.NE.0 ) THEN
            RESULT = 2*COEFF*ETERM*SINH(U)
         ELSE
            RESULT = EXP( E + LOG(2*COEFF) )*SINH(U)
         ENDIF
      ELSE
         E = -R*(T-HALF)**2
         ETERM = EXP(E)
         IF ( ETERM.NE.0 ) THEN
            RESULT = COEFF*ETERM
         ELSE
            RESULT = EXP( E + LOG(COEFF) )
         ENDIF
         E = -2*U
         IF ( E.GT.ELOW ) RESULT = RESULT*( 1 - EXP(E) )
      ENDIF
      RESULT = FSIGN*RESULT
      GO TO 50
C----------------------------------------------------------------------
C
C--Basic function THETA3.
C
C  Reduce argument T to the interval (0,1/2).
   30 T = ABS(T) - AINT(ABS(T))
      IF ( T.GE.HALF ) T = 1 - T
      IF ( Q .GT. C30+C31*T ) GO TO 34
C
C  Classical series.
C  (If Q has changed value, compute N3 and A3(j), j=0,1,...,N3)
      IF ( Q.NE.QPRV3A ) THEN
         QSQ = Q**2
         P = Q
         ATEMP = 1
         DO 31 J = 0,IADIM
            A3(J) = ATEMP
            N3 = J
            ATEMP = P*ATEMP
            P = QSQ*P
            IF ( 1-ATEMP .EQ. 1 ) GO TO 32
   31    CONTINUE
   32    QPRV3A= Q
      ENDIF
C  (Compute the series using Clenshaw recurrence)
      ALPHA = 2*COS(2*PI*T)
      W = 0
      V = 0
      U = A3(N3)
      DO 33 J = N3-1,0,-1
         W = V
         V = U
         U = A3(J) + ALPHA*V - W
   33 CONTINUE
      RESULT = U - W
      GO TO 50
C
C  Two-term cosh approximation.
   34    IF ( Q.EQ.1 ) THEN
            IF ( T.EQ.0 ) THEN
               WRITE(ERRTXT,103) K,X,Q
               CALL MTLPRT(NAME,'C349.3',ERRTXT)
            ENDIF
            RESULT = 0
            GO TO 50
         ENDIF
C
C  (If Q has changed value, compute R, B3 and COEFF)
         IF ( Q.NE.QPRV3B ) THEN
            ABSLOG = ABS(LOG(Q))
            R = PISQ/ABSLOG
            IF ( -R.GE.ELOW ) B3 = 2*EXP(-R)
            COEFF = SQRT(PI/ABSLOG)
            QPRV3B = Q
         ENDIF
C  (Compute function)
      E = - R*(T**2)
      RESULT = COEFF*EXP(E)
      IF ( RESULT.EQ.0 ) THEN
         RESULT = EXP( E + LOG(COEFF) )
      ENDIF
      E = -R*(1-2*T)
      IF ( E.GT.ELOW ) THEN
         ETEST = -R*(1+2*T)
         IF ( ETEST.GE.ELOW ) THEN
            RESULT = RESULT*( 1 + B3*COSH(2*R*T) )
         ELSE
            RESULT = RESULT*( 1 + EXP(E) )
         ENDIF
      ENDIF
C
C
C--Terminate.
   50 DTHETA = RESULT
      RETURN
C----------------------------------------------------------------------
C
C--Formats for error messages.
  101 FORMAT('Q < 0 or Q > 1       ',
     +       ' K=',I2,5X,'X=',1P,E13.5,5X,'Q=',E13.5)
  102 FORMAT('Impermissible K value',
     $       ' K=',I2,5X,'X=',1P,E13.5,5X,'Q=',E13.5)
  103 FORMAT('Function is infinite ',
     $       ' K=',I2,5X,'X=',1P,E13.5,5X,'Q=',E13.5)
      END
CDECK  ID>, SIMPS.  
C This will be SIMPS,IF=DOUBLE and SIMPS64,IF=-DOUBLE
      FUNCTION SIMPS(F,A,B,N2)

      CHARACTER NAME*(*)
      CHARACTER*80 ERRTXT
      PARAMETER (NAME = 'SIMPS')
      DIMENSION F(0:*)

      IF(N2 .LE. 0 .OR. 2*(N2/2) .NE. N2) THEN
       H=0
       WRITE(ERRTXT,101) N2+1
       CALL MTLPRT(NAME,'D101.1',ERRTXT)
      ELSE
*      S1=0
       S1=F(N2-1)
       S2=0
*      DO 1 N = 1,N2-1,2
*   1  S1=S1+F(N)
*      DO 2 N = 2,N2-2,2
*   2  S2=S2+F(N)

       DO 1 N = 1,N2-3,2
         S1=S1+F(N)
         S2=S2+F(N+1)
    1  CONTINUE
*      S1=S1+F(N2-1)

       S1=S1+S1+S2
       H=(F(0)+F(N2)+S1+S1)*(B-A)/(3*N2)
      ENDIF
      SIMPS=H
      RETURN
  101 FORMAT('NON-POSITIVE OR EVEN NUMBER OF FUNCTION VALUES =',I6)
      END
CDECK  ID>, SIMPS64.
      FUNCTION DSIMPS(F,A,B,N2)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      CHARACTER NAME*(*)
      CHARACTER*80 ERRTXT
      PARAMETER (NAME = 'DSIMPS')
      DIMENSION F(0:*)

      IF(N2 .LE. 0 .OR. 2*(N2/2) .NE. N2) THEN
       H=0
       WRITE(ERRTXT,101) N2+1
       CALL MTLPRT(NAME,'D101.1',ERRTXT)
      ELSE
*      S1=0
       S1=F(N2-1)
       S2=0
*      DO 1 N = 1,N2-1,2
*   1  S1=S1+F(N)
*      DO 2 N = 2,N2-2,2
*   2  S2=S2+F(N)

       DO 1 N = 1,N2-3,2
         S1=S1+F(N)
         S2=S2+F(N+1)
    1  CONTINUE
*      S1=S1+F(N2-1)

       S1=S1+S1+S2
       H=(F(0)+F(N2)+S1+S1)*(B-A)/(3*N2)
      ENDIF

      DSIMPS=H
      RETURN
  101 FORMAT('NON-POSITIVE OR EVEN NUMBER OF FUNCTION VALUES =',I6)
      END
CDECK  ID>, GAUSS.  
C This will be GAUSS,IF=DOUBLE and GAUSS64,IF=-DOUBLE.
      FUNCTION GAUSS(F,A,B,EPS)

      CHARACTER NAME*(*)
      PARAMETER (NAME = 'GAUSS')
      DIMENSION W(12),X(12)

      PARAMETER (Z1 = 1, HF = Z1/2, CST = 5*Z1/1000)

      DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
      DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
      DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
      DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
      DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
      DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
      DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
      DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
      DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
      DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
      DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
      DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/

      H=0
      IF(B .EQ. A) GO TO 99
      CONST=CST/ABS(B-A)
      BB=A
    1 AA=BB
      BB=B
    2 C1=HF*(BB+AA)
      C2=HF*(BB-AA)
      S8=0
      DO 3 I = 1,4
      U=C2*X(I)
    3 S8=S8+W(I)*(F(C1+U)+F(C1-U))
      S16=0
      DO 4 I = 5,12
      U=C2*X(I)
    4 S16=S16+W(I)*(F(C1+U)+F(C1-U))
      S16=C2*S16
      IF(ABS(S16-C2*S8) .LE. EPS*(1+ABS(S16))) THEN
       H=H+S16
       IF(BB .NE. B) GO TO 1
      ELSE
       BB=C1
       IF(1+CONST*ABS(C2) .NE. 1) GO TO 2
       H=0
       CALL MTLPRT(NAME,'D103.1','TOO HIGH ACCURACY REQUIRED')
       GO TO 99
      END IF
   99 GAUSS=H
      RETURN
      END
CDECK  ID>, GAUSS64.
      FUNCTION DGAUSS(F,A,B,EPS)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      CHARACTER NAME*(*)
      PARAMETER (NAME = 'DGAUSS')
      DIMENSION W(12),X(12)

      PARAMETER (Z1 = 1, HF = Z1/2, CST = 5*Z1/1000)

      DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
      DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
      DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
      DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
      DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
      DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
      DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
      DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
      DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
      DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
      DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
      DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/

      H=0
      IF(B .EQ. A) GO TO 99
      CONST=CST/ABS(B-A)
      BB=A
    1 AA=BB
      BB=B
    2 C1=HF*(BB+AA)
      C2=HF*(BB-AA)
      S8=0
      DO 3 I = 1,4
      U=C2*X(I)
    3 S8=S8+W(I)*(F(C1+U)+F(C1-U))
      S16=0
      DO 4 I = 5,12
      U=C2*X(I)
    4 S16=S16+W(I)*(F(C1+U)+F(C1-U))
      S16=C2*S16
      IF(ABS(S16-C2*S8) .LE. EPS*(1+ABS(S16))) THEN
       H=H+S16
       IF(BB .NE. B) GO TO 1
      ELSE
       BB=C1
       IF(1+CONST*ABS(C2) .NE. 1) GO TO 2
       H=0
       CALL MTLPRT(NAME,'D103.1','TOO HIGH ACCURACY REQUIRED')
       GO TO 99
      END IF

   99 DGAUSS=H
      RETURN
      END
CDECK  ID>, CAUCHY. 
      FUNCTION CAUCHY(F,A,B,S,EPS)
C
      CHARACTER NAME*(*)
      PARAMETER (NAME = 'CAUCHY')
      CALL MTLPRT(NAME,'D104.0','Not available on this machine')
      CAUCHY=0
      RETURN
      END
CDECK  ID>, CAUCHY64.   
      FUNCTION DCAUCH(F,A,B,S,EPS)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      CHARACTER NAME*(*)
      CHARACTER*80 ERRTXT
      PARAMETER (NAME = 'DCAUCH')
      EXTERNAL F

      DIMENSION X(12),W(12)

      PARAMETER (Z1 = 1, HF = Z1/2, CST = 5*Z1/1000)

      DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
      DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
      DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
      DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
      DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
      DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
      DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
      DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
      DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
      DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
      DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
      DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/

      IF(S .EQ. A .OR. S .EQ. B) THEN
       H=0
       WRITE(ERRTXT,101) S
       CALL MTLPRT(NAME,'D104.1',ERRTXT)
      ELSEIF(S .LT. MIN(A,B) .OR. S .GT. MAX(A,B)) THEN
       H=DGAUSS(F,A,B,EPS)
      ELSE
       IF(2*S .LE. A+B) THEN
        H=DGAUSS(F,2*S-A,B,EPS)
        B0=S-A
       ELSE
        H=DGAUSS(F,A,2*S-B,EPS)
        B0=B-S
       ENDIF
       C=CST/B0
       BB=0

    1  AA=BB
       BB=B0
    2  C1=HF*(BB+AA)
       C2=HF*(BB-AA)
       C3=S+C1
       C4=S-C1
       S8=0
       DO 3 I = 1,4
       U=C2*X(I)
    3  S8=S8+W(I)*((F(C3+U)+F(C4-U))+(F(C3-U)+F(C4+U)))
       S8=C2*S8
       S16=0
       DO 4 I = 5,12
       U=C2*X(I)
    4  S16=S16+W(I)*((F(C3+U)+F(C4-U))+(F(C3-U)+F(C4+U)))
       S16=C2*S16
       IF(ABS(S16-S8) .LE. EPS*(1+ABS(S16))) GO TO 5
       BB=C1
       IF(1+ABS(C*C2) .NE. 1) GO TO 2
       H=0
       CALL MTLPRT(NAME,'D104.2','TOO HIGH ACCURACY REQUIRED')
       GO TO 9
    5  H=H+S16
       IF(BB .NE. B0) GO TO 1
      END IF
    9 DCAUCH=H
      RETURN
  101 FORMAT('SINGULARITY  S = ',D15.8,' AT END-POINT OF INTERVAL')
      END
CDECK  ID>, TRIINT. 
C This will be TRIINT,IF=DOUBLE and TRIINT64,IF=-DOUBLE
      FUNCTION  TRIINT(F,NSD,NPT,EPS,X1,Y1,X2,Y2,X3,Y3)
C
C     INTEGRATION OVER A TRIANGLE USING A 7-, 25- OR 64-POINT FORMULA,
C     WITH OR WITHOUT SUBDIVISION OF THE TRIANGLE.
C
      CHARACTER NAME*(*)
      CHARACTER*80 ERRTXT
      PARAMETER (NAME = 'TRIINT')
      PARAMETER (Z1 = 1, HALF = Z1/2, KMX = 35)

      DIMENSION R(KMX),XP1(KMX),XP2(KMX),XP3(KMX),YP1(KMX),YP2(KMX)
      DIMENSION YP3(KMX)
      DIMENSION U(8,3),V(32,3),W(32,3),UU(5,2),WW(5,2)
      DIMENSION G1(32),G2(32)
      DIMENSION JZ(3),JZ0(3),JZ1(3),IZ(3,3)

      DATA JZ /2,5,8/, JZ0 /2,10,32/, JZ1 /3,5,0/
      DATA ((IZ(I,M),I=1,3),M=1,3) /1,0,1, 5,5,1, 8,24,8/

      DATA (U(J,1),J=1,2)
     1/0.89871 34926 76543 661D0, 0.52985 79358 94884 910D0/

      DATA (UU(J,1),J=1,3)
     1/0.20257 30146 46912 678D0, 0.94028 41282 10230 180D0,
     2 0.66666 66666 66666 667D0/

      DATA (V(J,1),J=1,2)
     1/0.69614 04780 29630 984D0,-0.41042 61923 15345 269D0/

      DATA (W(J,1),J=1,2)
     1/0.12593 91805 44827 153D0, 0.13239 41527 88506 181D0/

      DATA (WW(J,1),J=1,3)
     1/0.12593 91805 44827 153D0, 0.13239 41527 88506 181D0,
     2 0.22500 00000 00000 000D0/

      DATA (U(J,2),J=1,5)
     1/0.09853 50857 98826 426D0, 0.30453 57266 46363 905D0,
     2 0.56202 51897 52613 856D0, 0.80198 65821 26391 827D0,
     3 0.96019 01429 48531 258D0/

      DATA (UU(J,2),J=1,5)
     1/0.09853 50857 98826 426D0, 0.30453 57266 46363 905D0,
     2 0.56202 51897 52613 856D0, 0.80198 65821 26391 827D0,
     3 0.96019 01429 48531 258D0/

      DATA (V(J,2),J=1,10)
     1/0.08929 05088 68733 569D0, 0.27596 41378 55221 135D0,
     2 0.50929 58998 63672 021D0, 0.72674 40774 36169 444D0,
     3 0.87010 49558 08923 811D0, 0.05305 81196 71298 357D0,
     4 0.16398 31426 29800 463D0, 0.30263 33161 88105 613D0,
     5 0.43184 51615 91612 961D0, 0.51703 29238 43772 854D0/

      DATA (W(J,2),J=1,10)
     1/0.00373 11043 33755 67687D0, 0.01751 09983 64327 66347D0,
     2 0.03468 30128 62731 40026D0, 0.03960 81662 64094 70756D0,
     3 0.02293 01607 03185 09559D0, 0.00753 74033 90655 24076D0,
     4 0.03537 49042 20966 93175D0, 0.07006 50090 06743 44063D0,
     5 0.08001 45747 72320 84819D0, 0.04632 24438 58996 77269D0/

      DATA (WW(J,2),J=1,5)
     1/0.00895 88135 94562 71712D0, 0.04204 59349 74644 15024D0,
     2 0.08327 79304 30389 93562D0, 0.09510 37941 15908 01948D0,
     3 0.05505 79713 28939 62198D0/

      DATA (U(J,3),J=1,8)
     1/0.04463 39552 89969 851D0, 0.14436 62570 42145 571D0,
     2 0.28682 47571 44430 519D0, 0.45481 33151 96573 351D0,
     3 0.62806 78354 16727 698D0, 0.78569 15206 04369 242D0,
     4 0.90867 63921 00206 044D0, 0.98222 00848 52636 548D0/

      DATA (V(J,3),J=1,32)
     1/0.04286 15345 20322 596D0, 0.13863 34522 58088 400D0,
     2 0.27543 49048 78165 863D0, 0.43675 26131 83286 138D0,
     3 0.60312 71715 43047 645D0, 0.75449 15975 72500 770D0,
     4 0.87259 27221 72605 828D0, 0.94321 59843 32136 212D0,
     5 0.03555 83759 33897 592D0, 0.11501 17574 55156 297D0,
     6 0.22850 36689 09272 431D0, 0.36233 45216 98467 603D0,
     7 0.50036 05900 18245 933D0, 0.62593 40960 53638 777D0,
     8 0.72391 20204 03394 633D0, 0.78250 18150 44463 514D0,
     9 0.02345 65900 87635 536D0, 0.07586 91469 73958 963D0,
     A 0.15073 57058 45778 370D0, 0.23901 91375 97290 126D0,
     B 0.33007 00031 37485 188D0, 0.41290 63582 74039 218D0,
     C 0.47753 88941 74496 369D0, 0.51618 84882 60827 229D0,
     D 0.00818 74136 31782 437D0, 0.02648 17727 48961 059D0,
     E 0.05261 35967 85690 189D0, 0.08342 85178 75344 723D0,
     F 0.11520 93988 52684 066D0, 0.14412 30431 93925 944D0,
     G 0.16668 27291 29138 200D0, 0.18017 31901 16990 201D0/

      DATA (W(J,3),J=1,32)
     1/0.00033 35674 06495 41982D0, 0.00180 62109 19037 15084D0,
     2 0.00459 97558 03491 41419D0, 0.00801 72595 31391 49525D0,
     3 0.01073 50189 73158 61631D0, 0.01138 87974 04616 51588D0,
     4 0.00922 38453 90918 29977D0, 0.00450 98127 16079 21752D0,
     5 0.00073 27880 81649 19485D0, 0.00396 79231 50289 07586D0,
     6 0.01010 48428 76312 33624D0, 0.01761 24888 63394 88637D0,
     7 0.02358 29214 92410 93797D0, 0.02501 91560 68339 84265D0,
     8 0.02026 31427 34638 24614D0, 0.00990 72539 59652 71520D0,
     9 0.00103 37234 54873 38862D0, 0.00559 74371 44935 08001D0,
     A 0.01425 46165 12792 75399D0, 0.02484 54407 11607 46855D0,
     B 0.03326 77614 32852 32482D0, 0.03529 38169 93822 26192D0,
     C 0.02858 46432 80634 70277D0, 0.01397 58834 07425 66299D0,
     D 0.00119 51124 99230 79556D0, 0.00647 13314 41724 90169D0,
     E 0.01648 01043 12102 39366D0, 0.02872 44103 85925 30995D0,
     F 0.03846 16575 37508 13161D0, 0.04080 40290 04108 74571D0,
     G 0.03304 73922 30182 37768D0, 0.01615 78542 78398 33562D0/

      IF(NPT .EQ. 7) THEN
       M=1
      ELSE IF(NPT .EQ. 25) THEN
       M=2
      ELSE IF(NPT .EQ. 64) THEN
       M=3
      ELSE
       H=0
       WRITE(ERRTXT,101) NPT
       CALL MTLPRT(NAME,'D105.1',ERRTXT)
       GO TO 99
      END IF
      K=0
      C1=X1
      D1=Y1
      C2=X2
      D2=Y2
      C3=X3
      D3=Y3
      A11=HALF*(C2+C3)-C1
      A12=HALF*(C3-C2)
      A21=HALF*(D2+D3)-D1
      A22=HALF*(D3-D2)
      DO 1 J = 1,JZ(M)
      G1(J)=A11*U(J,M)+C1
      G2(J)=A21*U(J,M)+D1
      DO 1 I = IZ(1,M),IZ(2,M),IZ(3,M)
      G1(J+I)=G1(J)
    1 G2(J+I)=G2(J)
      S=0
      DO 2 J = 1,JZ0(M)
      H1=A12*V(J,M)
      H2=A22*V(J,M)
    2 S=S+W(J,M)*(F(G1(J)+H1,G2(J)+H2)+F(G1(J)-H1,G2(J)-H2))
      DO 3 J = 1,JZ1(M)
    3 S=S+WW(J,M)*F(A11*UU(J,M)+C1,A21*UU(J,M)+D1)
      S=HALF*ABS(C1*(D2-D3)+C2*(D3-D1)+C3*(D1-D2))*S
      H=S
      IF(NSD .EQ. 0) GO TO 99
      H=0

   10 K=K+1
      SUM0=S
      U1=C1
      V1=D1
      U2=C2
      V2=D2
      U3=C3
      V3=D3
   11 C1=HALF*(U2+U3)
      D1=HALF*(V2+V3)
      C2=U1
      D2=V1
      C3=U2
      D3=V2
      XP1(K)=C1
      YP1(K)=D1
      XP2(K)=C2
      YP2(K)=D2
      XP3(K)=U3
      YP3(K)=V3
      A11=HALF*(C2+U3)-C1
      A12=HALF*(U3-C2)
      A21=HALF*(D2+V3)-D1
      A22=HALF*(V3-D2)
      DO 4 J = 1,JZ(M)
      G1(J)=A11*U(J,M)+C1
      G2(J)=A21*U(J,M)+D1
      DO 4 I = IZ(1,M),IZ(2,M),IZ(3,M)
      G1(J+I)=G1(J)
    4 G2(J+I)=G2(J)
      S=0
      DO 5 J = 1,JZ0(M)
      H1=A12*V(J,M)
      H2=A22*V(J,M)
    5 S=S+W(J,M)*(F(G1(J)+H1,G2(J)+H2)+F(G1(J)-H1,G2(J)-H2))
      DO 6 J = 1,JZ1(M)
    6 S=S+WW(J,M)*F(A11*UU(J,M)+C1,A21*UU(J,M)+D1)
      S=HALF*ABS(C1*(D2-V3)+C2*(V3-D1)+U3*(D1-D2))*S
      R(K)=S
      A11=HALF*(C2+C3)-C1
      A12=HALF*(C3-C2)
      A21=HALF*(D2+D3)-D1
      A22=HALF*(D3-D2)
      DO 7 J = 1,JZ(M)
      G1(J)=A11*U(J,M)+C1
      G2(J)=A21*U(J,M)+D1
      DO 7 I = IZ(1,M),IZ(2,M),IZ(3,M)
      G1(J+I)=G1(J)
    7 G2(J+I)=G2(J)
      S=0
      DO 8 J = 1,JZ0(M)
      H1=A12*V(J,M)
      H2=A22*V(J,M)
    8 S=S+W(J,M)*(F(G1(J)+H1,G2(J)+H2)+F(G1(J)-H1,G2(J)-H2))
      DO 9 J = 1,JZ1(M)
    9 S=S+WW(J,M)*F(A11*UU(J,M)+C1,A21*UU(J,M)+D1)
      S=HALF*ABS(C1*(D2-D3)+C2*(D3-D1)+C3*(D1-D2))*S
      SUM=S+R(K)
      IF(ABS(SUM0-SUM) .GT. EPS*(1+ABS(SUM))) THEN
       IF(K .LT. KMX) GO TO 10
       H=0
       CALL MTLPRT(NAME,'D105.2','TOO HIGH ACCURACY REQUIRED')
       GO TO 99
      ELSE
       H=H+SUM
       K=K-1
       IF(K .LE. 0)  GO TO 99
       U1=XP1(K)
       V1=YP1(K)
       U2=XP2(K)
       V2=YP2(K)
       U3=XP3(K)
       V3=YP3(K)
       SUM0=R(K)
       GO TO 11
      END IF


   99  TRIINT=H
      RETURN
  101 FORMAT('INCORRECT NUMBER OF POINTS =',I5)
      END
CDECK  ID>, TRIINT64.   
      FUNCTION DTRINT(F,NSD,NPT,EPS,X1,Y1,X2,Y2,X3,Y3)
C     INTEGRATION OVER A TRIANGLE USING A 7-, 25- OR 64-POINT FORMULA,
C     WITH OR WITHOUT SUBDIVISION OF THE TRIANGLE.

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      CHARACTER NAME*(*)
      CHARACTER*80 ERRTXT
      PARAMETER (NAME = 'DTRINT')
      PARAMETER (Z1 = 1, HALF = Z1/2, KMX = 35)

      DIMENSION R(KMX),XP1(KMX),XP2(KMX),XP3(KMX),YP1(KMX),YP2(KMX)
      DIMENSION YP3(KMX)
      DIMENSION U(8,3),V(32,3),W(32,3),UU(5,2),WW(5,2)
      DIMENSION G1(32),G2(32)
      DIMENSION JZ(3),JZ0(3),JZ1(3),IZ(3,3)

      DATA JZ /2,5,8/, JZ0 /2,10,32/, JZ1 /3,5,0/
      DATA ((IZ(I,M),I=1,3),M=1,3) /1,0,1, 5,5,1, 8,24,8/

      DATA (U(J,1),J=1,2)
     1/0.89871 34926 76543 661D0, 0.52985 79358 94884 910D0/

      DATA (UU(J,1),J=1,3)
     1/0.20257 30146 46912 678D0, 0.94028 41282 10230 180D0,
     2 0.66666 66666 66666 667D0/

      DATA (V(J,1),J=1,2)
     1/0.69614 04780 29630 984D0,-0.41042 61923 15345 269D0/

      DATA (W(J,1),J=1,2)
     1/0.12593 91805 44827 153D0, 0.13239 41527 88506 181D0/

      DATA (WW(J,1),J=1,3)
     1/0.12593 91805 44827 153D0, 0.13239 41527 88506 181D0,
     2 0.22500 00000 00000 000D0/

      DATA (U(J,2),J=1,5)
     1/0.09853 50857 98826 426D0, 0.30453 57266 46363 905D0,
     2 0.56202 51897 52613 856D0, 0.80198 65821 26391 827D0,
     3 0.96019 01429 48531 258D0/

      DATA (UU(J,2),J=1,5)
     1/0.09853 50857 98826 426D0, 0.30453 57266 46363 905D0,
     2 0.56202 51897 52613 856D0, 0.80198 65821 26391 827D0,
     3 0.96019 01429 48531 258D0/

      DATA (V(J,2),J=1,10)
     1/0.08929 05088 68733 569D0, 0.27596 41378 55221 135D0,
     2 0.50929 58998 63672 021D0, 0.72674 40774 36169 444D0,
     3 0.87010 49558 08923 811D0, 0.05305 81196 71298 357D0,
     4 0.16398 31426 29800 463D0, 0.30263 33161 88105 613D0,
     5 0.43184 51615 91612 961D0, 0.51703 29238 43772 854D0/

      DATA (W(J,2),J=1,10)
     1/0.00373 11043 33755 67687D0, 0.01751 09983 64327 66347D0,
     2 0.03468 30128 62731 40026D0, 0.03960 81662 64094 70756D0,
     3 0.02293 01607 03185 09559D0, 0.00753 74033 90655 24076D0,
     4 0.03537 49042 20966 93175D0, 0.07006 50090 06743 44063D0,
     5 0.08001 45747 72320 84819D0, 0.04632 24438 58996 77269D0/

      DATA (WW(J,2),J=1,5)
     1/0.00895 88135 94562 71712D0, 0.04204 59349 74644 15024D0,
     2 0.08327 79304 30389 93562D0, 0.09510 37941 15908 01948D0,
     3 0.05505 79713 28939 62198D0/

      DATA (U(J,3),J=1,8)
     1/0.04463 39552 89969 851D0, 0.14436 62570 42145 571D0,
     2 0.28682 47571 44430 519D0, 0.45481 33151 96573 351D0,
     3 0.62806 78354 16727 698D0, 0.78569 15206 04369 242D0,
     4 0.90867 63921 00206 044D0, 0.98222 00848 52636 548D0/

      DATA (V(J,3),J=1,32)
     1/0.04286 15345 20322 596D0, 0.13863 34522 58088 400D0,
     2 0.27543 49048 78165 863D0, 0.43675 26131 83286 138D0,
     3 0.60312 71715 43047 645D0, 0.75449 15975 72500 770D0,
     4 0.87259 27221 72605 828D0, 0.94321 59843 32136 212D0,
     5 0.03555 83759 33897 592D0, 0.11501 17574 55156 297D0,
     6 0.22850 36689 09272 431D0, 0.36233 45216 98467 603D0,
     7 0.50036 05900 18245 933D0, 0.62593 40960 53638 777D0,
     8 0.72391 20204 03394 633D0, 0.78250 18150 44463 514D0,
     9 0.02345 65900 87635 536D0, 0.07586 91469 73958 963D0,
     A 0.15073 57058 45778 370D0, 0.23901 91375 97290 126D0,
     B 0.33007 00031 37485 188D0, 0.41290 63582 74039 218D0,
     C 0.47753 88941 74496 369D0, 0.51618 84882 60827 229D0,
     D 0.00818 74136 31782 437D0, 0.02648 17727 48961 059D0,
     E 0.05261 35967 85690 189D0, 0.08342 85178 75344 723D0,
     F 0.11520 93988 52684 066D0, 0.14412 30431 93925 944D0,
     G 0.16668 27291 29138 200D0, 0.18017 31901 16990 201D0/

      DATA (W(J,3),J=1,32)
     1/0.00033 35674 06495 41982D0, 0.00180 62109 19037 15084D0,
     2 0.00459 97558 03491 41419D0, 0.00801 72595 31391 49525D0,
     3 0.01073 50189 73158 61631D0, 0.01138 87974 04616 51588D0,
     4 0.00922 38453 90918 29977D0, 0.00450 98127 16079 21752D0,
     5 0.00073 27880 81649 19485D0, 0.00396 79231 50289 07586D0,
     6 0.01010 48428 76312 33624D0, 0.01761 24888 63394 88637D0,
     7 0.02358 29214 92410 93797D0, 0.02501 91560 68339 84265D0,
     8 0.02026 31427 34638 24614D0, 0.00990 72539 59652 71520D0,
     9 0.00103 37234 54873 38862D0, 0.00559 74371 44935 08001D0,
     A 0.01425 46165 12792 75399D0, 0.02484 54407 11607 46855D0,
     B 0.03326 77614 32852 32482D0, 0.03529 38169 93822 26192D0,
     C 0.02858 46432 80634 70277D0, 0.01397 58834 07425 66299D0,
     D 0.00119 51124 99230 79556D0, 0.00647 13314 41724 90169D0,
     E 0.01648 01043 12102 39366D0, 0.02872 44103 85925 30995D0,
     F 0.03846 16575 37508 13161D0, 0.04080 40290 04108 74571D0,
     G 0.03304 73922 30182 37768D0, 0.01615 78542 78398 33562D0/

      IF(NPT .EQ. 7) THEN
       M=1
      ELSE IF(NPT .EQ. 25) THEN
       M=2
      ELSE IF(NPT .EQ. 64) THEN
       M=3
      ELSE
       H=0
       WRITE(ERRTXT,101) NPT
       CALL MTLPRT(NAME,'D105.1',ERRTXT)
       GO TO 99
      END IF
      K=0
      C1=X1
      D1=Y1
      C2=X2
      D2=Y2
      C3=X3
      D3=Y3
      A11=HALF*(C2+C3)-C1
      A12=HALF*(C3-C2)
      A21=HALF*(D2+D3)-D1
      A22=HALF*(D3-D2)
      DO 1 J = 1,JZ(M)
      G1(J)=A11*U(J,M)+C1
      G2(J)=A21*U(J,M)+D1
      DO 1 I = IZ(1,M),IZ(2,M),IZ(3,M)
      G1(J+I)=G1(J)
    1 G2(J+I)=G2(J)
      S=0
      DO 2 J = 1,JZ0(M)
      H1=A12*V(J,M)
      H2=A22*V(J,M)
    2 S=S+W(J,M)*(F(G1(J)+H1,G2(J)+H2)+F(G1(J)-H1,G2(J)-H2))
      DO 3 J = 1,JZ1(M)
    3 S=S+WW(J,M)*F(A11*UU(J,M)+C1,A21*UU(J,M)+D1)
      S=HALF*ABS(C1*(D2-D3)+C2*(D3-D1)+C3*(D1-D2))*S
      H=S
      IF(NSD .EQ. 0) GO TO 99
      H=0

   10 K=K+1
      SUM0=S
      U1=C1
      V1=D1
      U2=C2
      V2=D2
      U3=C3
      V3=D3
   11 C1=HALF*(U2+U3)
      D1=HALF*(V2+V3)
      C2=U1
      D2=V1
      C3=U2
      D3=V2
      XP1(K)=C1
      YP1(K)=D1
      XP2(K)=C2
      YP2(K)=D2
      XP3(K)=U3
      YP3(K)=V3
      A11=HALF*(C2+U3)-C1
      A12=HALF*(U3-C2)
      A21=HALF*(D2+V3)-D1
      A22=HALF*(V3-D2)
      DO 4 J = 1,JZ(M)
      G1(J)=A11*U(J,M)+C1
      G2(J)=A21*U(J,M)+D1
      DO 4 I = IZ(1,M),IZ(2,M),IZ(3,M)
      G1(J+I)=G1(J)
    4 G2(J+I)=G2(J)
      S=0
      DO 5 J = 1,JZ0(M)
      H1=A12*V(J,M)
      H2=A22*V(J,M)
    5 S=S+W(J,M)*(F(G1(J)+H1,G2(J)+H2)+F(G1(J)-H1,G2(J)-H2))
      DO 6 J = 1,JZ1(M)
    6 S=S+WW(J,M)*F(A11*UU(J,M)+C1,A21*UU(J,M)+D1)
      S=HALF*ABS(C1*(D2-V3)+C2*(V3-D1)+U3*(D1-D2))*S
      R(K)=S
      A11=HALF*(C2+C3)-C1
      A12=HALF*(C3-C2)
      A21=HALF*(D2+D3)-D1
      A22=HALF*(D3-D2)
      DO 7 J = 1,JZ(M)
      G1(J)=A11*U(J,M)+C1
      G2(J)=A21*U(J,M)+D1
      DO 7 I = IZ(1,M),IZ(2,M),IZ(3,M)
      G1(J+I)=G1(J)
    7 G2(J+I)=G2(J)
      S=0
      DO 8 J = 1,JZ0(M)
      H1=A12*V(J,M)
      H2=A22*V(J,M)
    8 S=S+W(J,M)*(F(G1(J)+H1,G2(J)+H2)+F(G1(J)-H1,G2(J)-H2))
      DO 9 J = 1,JZ1(M)
    9 S=S+WW(J,M)*F(A11*UU(J,M)+C1,A21*UU(J,M)+D1)
      S=HALF*ABS(C1*(D2-D3)+C2*(D3-D1)+C3*(D1-D2))*S
      SUM=S+R(K)
      IF(ABS(SUM0-SUM) .GT. EPS*(1+ABS(SUM))) THEN
       IF(K .LT. KMX) GO TO 10
       H=0
       CALL MTLPRT(NAME,'D105.2','TOO HIGH ACCURACY REQUIRED')
       GO TO 99
      ELSE
       H=H+SUM
       K=K-1
       IF(K .LE. 0)  GO TO 99
       U1=XP1(K)
       V1=YP1(K)
       U2=XP2(K)
       V2=YP2(K)
       U3=XP3(K)
       V3=YP3(K)
       SUM0=R(K)
       GO TO 11
      END IF


   99 DTRINT=H
      RETURN
  101 FORMAT('INCORRECT NUMBER OF POINTS =',I5)
      END
CDECK  ID>, RGQUAD64.   
      FUNCTION DGQUAD(F,A,B,N)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION X(1),W(1)
      EXTERNAL F

      CALL D107S1(1,F,A,B,N,X,W)
      DGQUAD=X(1)
      RETURN
      END
CDECK  ID>, RGSET64.
      SUBROUTINE DGSET(A,B,N,X,W)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      EXTERNAL DGQUAD
      DIMENSION X(*),W(*)

      CALL D107S1(2,DGQUAD,A,B,N,X,W)
      RETURN
      END
CDECK  ID>, D107S164.   
      SUBROUTINE D107S1(MODE,F,A,B,N,X,W)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      CHARACTER*6 NAME(2)

      DIMENSION X(*),W(*),KTBA(97),U(273),V(273)
      PARAMETER (Z1 = 1, HF = Z1/2)

      CHARACTER*80 ERRTXT

      DATA NAME /'DGQUAD','DGSET'/

      DATA KTBA
     1/0,1,2,4,6,9,12,16,20,25,30,36,42,49,56,64,3*0,72,3*0,82,7*0,94,
     2 7*0,110,7*0,130,15*0,154,15*0,186,15*0,226,0/

C  N=2.
      DATA U(1)  /5.7735026918962576D-1/, V(1)  /1/
C  N=3.
      DATA U(2)  /7.7459666924148338D-1/, V(2)  /5.5555555555555556D-1/
      DATA U(3)  /0/                    , V(3)  /8.8888888888888889D-1/
C  N=4.
      DATA U(4)  /8.6113631159405258D-1/, V(4)  /3.4785484513745386D-1/
      DATA U(5)  /3.3998104358485626D-1/, V(5)  /6.5214515486254614D-1/
C  N=5.
      DATA U(6)  /9.0617984593866399D-1/, V(6)  /2.3692688505618909D-1/
      DATA U(7)  /5.3846931010568309D-1/, V(7)  /4.7862867049936647D-1/
      DATA U(8)  /0/,                     V(8)  /5.6888888888888889D-1/
C  N=6.
      DATA U(9)  /9.3246951420315203D-1/, V(9)  /1.7132449237917035D-1/
      DATA U(10) /6.6120938646626451D-1/, V(10) /3.6076157304813861D-1/
      DATA U(11) /2.3861918608319691D-1/, V(11) /4.6791393457269105D-1/
C  N=7.
      DATA U(12) /9.4910791234275852D-1/, V(12) /1.2948496616886969D-1/
      DATA U(13) /7.4153118559939444D-1/, V(13) /2.7970539148927667D-1/
      DATA U(14) /4.0584515137739717D-1/, V(14) /3.8183005050511894D-1/
      DATA U(15) /0/                    , V(15) /4.1795918367346939D-1/
C  N=8.
      DATA U(16) /9.6028985649753623D-1/, V(16) /1.0122853629037626D-1/
      DATA U(17) /7.9666647741362674D-1/, V(17) /2.2238103445337447D-1/
      DATA U(18) /5.2553240991632899D-1/, V(18) /3.1370664587788729D-1/
      DATA U(19) /1.8343464249564980D-1/, V(19) /3.6268378337836198D-1/
C  N=9.
      DATA U(20) /9.6816023950762609D-1/, V(20) /8.1274388361574412D-2/
      DATA U(21) /8.3603110732663579D-1/, V(21) /1.8064816069485740D-1/
      DATA U(22) /6.1337143270059040D-1/, V(22) /2.6061069640293546D-1/
      DATA U(23) /3.2425342340380893D-1/, V(23) /3.1234707704000284D-1/
      DATA U(24) /0/                    , V(24) /3.3023935500125976D-1/
C  N=10.
      DATA U(25) /9.7390652851717172D-1/, V(25) /6.6671344308688138D-2/
      DATA U(26) /8.6506336668898451D-1/, V(26) /1.4945134915058059D-1/
      DATA U(27) /6.7940956829902441D-1/, V(27) /2.1908636251598204D-1/
      DATA U(28) /4.3339539412924719D-1/, V(28) /2.6926671930999636D-1/
      DATA U(29) /1.4887433898163121D-1/, V(29) /2.9552422471475287D-1/
C  N=11.
      DATA U(30) /9.7822865814605699D-1/, V(30) /5.5668567116173666D-2/
      DATA U(31) /8.8706259976809530D-1/, V(31) /1.2558036946490462D-1/
      DATA U(32) /7.3015200557404932D-1/, V(32) /1.8629021092773425D-1/
      DATA U(33) /5.1909612920681182D-1/, V(33) /2.3319376459199048D-1/
      DATA U(34) /2.6954315595234497D-1/, V(34) /2.6280454451024666D-1/
      DATA U(35) /0/                    , V(35) /2.7292508677790063D-1/
C  N=12.
      DATA U(36) /9.8156063424671925D-1/, V(36) /4.7175336386511827D-2/
      DATA U(37) /9.0411725637047486D-1/, V(37) /1.0693932599531843D-1/
      DATA U(38) /7.6990267419430469D-1/, V(38) /1.6007832854334623D-1/
      DATA U(39) /5.8731795428661745D-1/, V(39) /2.0316742672306592D-1/
      DATA U(40) /3.6783149899818019D-1/, V(40) /2.3349253653835481D-1/
      DATA U(41) /1.2523340851146892D-1/, V(41) /2.4914704581340279D-1/
C  N=13.
      DATA U(42) /9.8418305471858815D-1/, V(42) /4.0484004765315880D-2/
      DATA U(43) /9.1759839922297797D-1/, V(43) /9.2121499837728448D-2/
      DATA U(44) /8.0157809073330991D-1/, V(44) /1.3887351021978724D-1/
      DATA U(45) /6.4234933944034022D-1/, V(45) /1.7814598076194574D-1/
      DATA U(46) /4.4849275103644685D-1/, V(46) /2.0781604753688850D-1/
      DATA U(47) /2.3045831595513479D-1/, V(47) /2.2628318026289724D-1/
      DATA U(48) /0/                    , V(48) /2.3255155323087391D-1/
C  N=14.
      DATA U(49) /9.8628380869681234D-1/, V(49) /3.5119460331751863D-2/
      DATA U(50) /9.2843488366357352D-1/, V(50) /8.0158087159760210D-2/
      DATA U(51) /8.2720131506976499D-1/, V(51) /1.2151857068790318D-1/
      DATA U(52) /6.8729290481168547D-1/, V(52) /1.5720316715819353D-1/
      DATA U(53) /5.1524863635815409D-1/, V(53) /1.8553839747793781D-1/
      DATA U(54) /3.1911236892788976D-1/, V(54) /2.0519846372129560D-1/
      DATA U(55) /1.0805494870734366D-1/, V(55) /2.1526385346315779D-1/
C  N=15.
      DATA U(56) /9.8799251802048543D-1/, V(56) /3.0753241996117268D-2/
      DATA U(57) /9.3727339240070590D-1/, V(57) /7.0366047488108125D-2/
      DATA U(58) /8.4820658341042722D-1/, V(58) /1.0715922046717194D-1/
      DATA U(59) /7.2441773136017005D-1/, V(59) /1.3957067792615431D-1/
      DATA U(60) /5.7097217260853885D-1/, V(60) /1.6626920581699393D-1/
      DATA U(61) /3.9415134707756337D-1/, V(61) /1.8616100001556221D-1/
      DATA U(62) /2.0119409399743452D-1/, V(62) /1.9843148532711158D-1/
      DATA U(63) /0/                    , V(63) /2.0257824192556127D-1/
C  N=16.
      DATA U(64) /9.8940093499164993D-1/, V(64) /2.7152459411754095D-2/
      DATA U(65) /9.4457502307323258D-1/, V(65) /6.2253523938647893D-2/
      DATA U(66) /8.6563120238783174D-1/, V(66) /9.5158511682492785D-2/
      DATA U(67) /7.5540440835500303D-1/, V(67) /1.2462897125553387D-1/
      DATA U(68) /6.1787624440264375D-1/, V(68) /1.4959598881657673D-1/
      DATA U(69) /4.5801677765722739D-1/, V(69) /1.6915651939500254D-1/
      DATA U(70) /2.8160355077925891D-1/, V(70) /1.8260341504492359D-1/
      DATA U(71) /9.5012509837637440D-2/, V(71) /1.8945061045506850D-1/
C  N=20.
      DATA U(72) /9.9312859918509492D-1/, V(72) /1.7614007139152118D-2/
      DATA U(73) /9.6397192727791379D-1/, V(73) /4.0601429800386941D-2/
      DATA U(74) /9.1223442825132591D-1/, V(74) /6.2672048334109064D-2/
      DATA U(75) /8.3911697182221882D-1/, V(75) /8.3276741576704749D-2/
      DATA U(76) /7.4633190646015079D-1/, V(76) /1.0193011981724044D-1/
      DATA U(77) /6.3605368072651503D-1/, V(77) /1.1819453196151842D-1/
      DATA U(78) /5.1086700195082710D-1/, V(78) /1.3168863844917663D-1/
      DATA U(79) /3.7370608871541956D-1/, V(79) /1.4209610931838205D-1/
      DATA U(80) /2.2778585114164508D-1/, V(80) /1.4917298647260374D-1/
      DATA U(81) /7.6526521133497334D-2/, V(81) /1.5275338713072585D-1/
C  N=24.
      DATA U(82) /9.9518721999702136D-1/, V(82) /1.2341229799987200D-2/
      DATA U(83) /9.7472855597130950D-1/, V(83) /2.8531388628933663D-2/
      DATA U(84) /9.3827455200273276D-1/, V(84) /4.4277438817419806D-2/
      DATA U(85) /8.8641552700440103D-1/, V(85) /5.9298584915436781D-2/
      DATA U(86) /8.2000198597390292D-1/, V(86) /7.3346481411080306D-2/
      DATA U(87) /7.4012419157855436D-1/, V(87) /8.6190161531953276D-2/
      DATA U(88) /6.4809365193697557D-1/, V(88) /9.7618652104113888D-2/
      DATA U(89) /5.4542147138883954D-1/, V(89) /1.0744427011596563D-1/
      DATA U(90) /4.3379350762604514D-1/, V(90) /1.1550566805372560D-1/
      DATA U(91) /3.1504267969616337D-1/, V(91) /1.2167047292780339D-1/
      DATA U(92) /1.9111886747361631D-1/, V(92) /1.2583745634682830D-1/
      DATA U(93) /6.4056892862605626D-2/, V(93) /1.2793819534675216D-1/
C  N=32.
      DATA U(94) /9.9726386184948156D-1/, V(94) /7.0186100094700966D-3/
      DATA U(95) /9.8561151154526834D-1/, V(95) /1.6274394730905671D-2/
      DATA U(96) /9.6476225558750643D-1/, V(96) /2.5392065309262059D-2/
      DATA U(97) /9.3490607593773969D-1/, V(97) /3.4273862913021433D-2/
      DATA U(98) /8.9632115576605212D-1/, V(98) /4.2835898022226681D-2/
      DATA U(99) /8.4936761373256997D-1/, V(99) /5.0998059262376176D-2/
      DATA U(100)/7.9448379596794241D-1/, V(100)/5.8684093478535547D-2/
      DATA U(101)/7.3218211874028968D-1/, V(101)/6.5822222776361847D-2/
      DATA U(102)/6.6304426693021520D-1/, V(102)/7.2345794108848506D-2/
      DATA U(103)/5.8771575724076233D-1/, V(103)/7.8193895787070306D-2/
      DATA U(104)/5.0689990893222939D-1/, V(104)/8.3311924226946755D-2/
      DATA U(105)/4.2135127613063535D-1/, V(105)/8.7652093004403811D-2/
      DATA U(106)/3.3186860228212765D-1/, V(106)/9.1173878695763885D-2/
      DATA U(107)/2.3928736225213707D-1/, V(107)/9.3844399080804566D-2/
      DATA U(108)/1.4447196158279649D-1/, V(108)/9.5638720079274859D-2/
      DATA U(109)/4.8307665687738316D-2/, V(109)/9.6540088514727801D-2/
C  N=40.
      DATA U(110)/9.9823770971055920D-1/, V(110)/4.5212770985331913D-3/
      DATA U(111)/9.9072623869945701D-1/, V(111)/1.0498284531152814D-2/
      DATA U(112)/9.7725994998377426D-1/, V(112)/1.6421058381907889D-2/
      DATA U(113)/9.5791681921379166D-1/, V(113)/2.2245849194166957D-2/
      DATA U(114)/9.3281280827867653D-1/, V(114)/2.7937006980023401D-2/
      DATA U(115)/9.0209880696887430D-1/, V(115)/3.3460195282547847D-2/
      DATA U(116)/8.6595950321225950D-1/, V(116)/3.8782167974472018D-2/
      DATA U(117)/8.2461223083331166D-1/, V(117)/4.3870908185673272D-2/
      DATA U(118)/7.7830565142651939D-1/, V(118)/4.8695807635072232D-2/
      DATA U(119)/7.2731825518992710D-1/, V(119)/5.3227846983936824D-2/
      DATA U(120)/6.7195668461417955D-1/, V(120)/5.7439769099391551D-2/
      DATA U(121)/6.1255388966798024D-1/, V(121)/6.1306242492928939D-2/
      DATA U(122)/5.4946712509512820D-1/, V(122)/6.4804013456601038D-2/
      DATA U(123)/4.8307580168617871D-1/, V(123)/6.7912045815233904D-2/
      DATA U(124)/4.1377920437160500D-1/, V(124)/7.0611647391286780D-2/
      DATA U(125)/3.4199409082575847D-1/, V(125)/7.2886582395804059D-2/
      DATA U(126)/2.6815218500725368D-1/, V(126)/7.4723169057968264D-2/
      DATA U(127)/1.9269758070137110D-1/, V(127)/7.6110361900626242D-2/
      DATA U(128)/1.1608407067525521D-1/, V(128)/7.7039818164247966D-2/
      DATA U(129)/3.8772417506050822D-2/, V(129)/7.7505947978424811D-2/
C  N=48.
      DATA U(130)/9.9877100725242612D-1/, V(130)/3.1533460523058386D-3/
      DATA U(131)/9.9353017226635076D-1/, V(131)/7.3275539012762621D-3/
      DATA U(132)/9.8412458372282686D-1/, V(132)/1.1477234579234539D-2/
      DATA U(133)/9.7059159254624725D-1/, V(133)/1.5579315722943849D-2/
      DATA U(134)/9.5298770316043086D-1/, V(134)/1.9616160457355528D-2/
      DATA U(135)/9.3138669070655433D-1/, V(135)/2.3570760839324379D-2/
      DATA U(136)/9.0587913671556967D-1/, V(136)/2.7426509708356948D-2/
      DATA U(137)/8.7657202027424789D-1/, V(137)/3.1167227832798089D-2/
      DATA U(138)/8.4358826162439353D-1/, V(138)/3.4777222564770439D-2/
      DATA U(139)/8.0706620402944263D-1/, V(139)/3.8241351065830706D-2/
      DATA U(140)/7.6715903251574034D-1/, V(140)/4.1545082943464749D-2/
      DATA U(141)/7.2403413092381465D-1/, V(141)/4.4674560856694280D-2/
      DATA U(142)/6.7787237963266391D-1/, V(142)/4.7616658492490475D-2/
      DATA U(143)/6.2886739677651362D-1/, V(143)/5.0359035553854475D-2/
      DATA U(144)/5.7722472608397270D-1/, V(144)/5.2890189485193667D-2/
      DATA U(145)/5.2316097472223303D-1/, V(145)/5.5199503699984163D-2/
      DATA U(146)/4.6690290475095840D-1/, V(146)/5.7277292100403216D-2/
      DATA U(147)/4.0868648199071673D-1/, V(147)/5.9114839698395636D-2/
      DATA U(148)/3.4875588629216074D-1/, V(148)/6.0704439165893880D-2/
      DATA U(149)/2.8736248735545558D-1/, V(149)/6.2039423159892664D-2/
      DATA U(150)/2.2476379039468906D-1/, V(150)/6.3114192286254026D-2/
      DATA U(151)/1.6122235606889172D-1/, V(151)/6.3924238584648187D-2/
      DATA U(152)/9.7004699209462699D-2/, V(152)/6.4466164435950082D-2/
      DATA U(153)/3.2380170962869362D-2/, V(153)/6.4737696812683923D-2/
C  N=64.
      DATA U(154)/9.9930504173577214D-1/, V(154)/1.7832807216964329D-3/
      DATA U(155)/9.9634011677195528D-1/, V(155)/4.1470332605624676D-3/
      DATA U(156)/9.9101337147674432D-1/, V(156)/6.5044579689783629D-3/
      DATA U(157)/9.8333625388462596D-1/, V(157)/8.8467598263639477D-3/
      DATA U(158)/9.7332682778991096D-1/, V(158)/1.1168139460131129D-2/
      DATA U(159)/9.6100879965205372D-1/, V(159)/1.3463047896718643D-2/
      DATA U(160)/9.4641137485840282D-1/, V(160)/1.5726030476024719D-2/
      DATA U(161)/9.2956917213193958D-1/, V(161)/1.7951715775697343D-2/
      DATA U(162)/9.1052213707850281D-1/, V(162)/2.0134823153530209D-2/
      DATA U(163)/8.8931544599511412D-1/, V(163)/2.2270173808383254D-2/
      DATA U(164)/8.6599939815409282D-1/, V(164)/2.4352702568710873D-2/
      DATA U(165)/8.4062929625258036D-1/, V(165)/2.6377469715054659D-2/
      DATA U(166)/8.1326531512279756D-1/, V(166)/2.8339672614259483D-2/
      DATA U(167)/7.8397235894334141D-1/, V(167)/3.0234657072402479D-2/
      DATA U(168)/7.5281990726053190D-1/, V(168)/3.2057928354851554D-2/
      DATA U(169)/7.1988185017161083D-1/, V(169)/3.3805161837141609D-2/
      DATA U(170)/6.8523631305423324D-1/, V(170)/3.5472213256882384D-2/
      DATA U(171)/6.4896547125465734D-1/, V(171)/3.7055128540240046D-2/
      DATA U(172)/6.1115535517239325D-1/, V(172)/3.8550153178615629D-2/
      DATA U(173)/5.7189564620263403D-1/, V(173)/3.9953741132720341D-2/
      DATA U(174)/5.3127946401989455D-1/, V(174)/4.1262563242623529D-2/
      DATA U(175)/4.8940314570705296D-1/, V(175)/4.2473515123653589D-2/
      DATA U(176)/4.4636601725346409D-1/, V(176)/4.3583724529323453D-2/
      DATA U(177)/4.0227015796399160D-1/, V(177)/4.4590558163756563D-2/
      DATA U(178)/3.5722015833766812D-1/, V(178)/4.5491627927418144D-2/
      DATA U(179)/3.1132287199021096D-1/, V(179)/4.6284796581314417D-2/
      DATA U(180)/2.6468716220876742D-1/, V(180)/4.6968182816210017D-2/
      DATA U(181)/2.1742364374000708D-1/, V(181)/4.7540165714830309D-2/
      DATA U(182)/1.6964442042399282D-1/, V(182)/4.7999388596458308D-2/
      DATA U(183)/1.2146281929612055D-1/, V(183)/4.8344762234802957D-2/
      DATA U(184)/7.2993121787799039D-2/, V(184)/4.8575467441503427D-2/
      DATA U(185)/2.4350292663424433D-2/, V(185)/4.8690957009139720D-2/
C  N=80.
      DATA U(186)/9.9955382265163063D-1/, V(186)/1.1449500031869415D-3/
      DATA U(187)/9.9764986439823769D-1/, V(187)/2.6635335895126817D-3/
      DATA U(188)/9.9422754096568828D-1/, V(188)/4.1803131246948952D-3/
      DATA U(189)/9.8929130249975553D-1/, V(189)/5.6909224514031986D-3/
      DATA U(190)/9.8284857273862907D-1/, V(190)/7.1929047681173128D-3/
      DATA U(191)/9.7490914058572779D-1/, V(191)/8.6839452692608584D-3/
      DATA U(192)/9.6548508904379925D-1/, V(192)/1.0161766041103065D-2/
      DATA U(193)/9.5459076634363491D-1/, V(193)/1.1624114120797827D-2/
      DATA U(194)/9.4224276130987267D-1/, V(194)/1.3068761592401339D-2/
      DATA U(195)/9.2845987717244580D-1/, V(195)/1.4493508040509076D-2/
      DATA U(196)/9.1326310257175765D-1/, V(196)/1.5896183583725688D-2/
      DATA U(197)/8.9667557943877068D-1/, V(197)/1.7274652056269306D-2/
      DATA U(198)/8.7872256767821383D-1/, V(198)/1.8626814208299031D-2/
      DATA U(199)/8.5943140666311110D-1/, V(199)/1.9950610878141999D-2/
      DATA U(200)/8.3883147358025528D-1/, V(200)/2.1244026115782006D-2/
      DATA U(201)/8.1695413868146347D-1/, V(201)/2.2505090246332462D-2/
      DATA U(202)/7.9383271750460545D-1/, V(202)/2.3731882865930101D-2/
      DATA U(203)/7.6950242013504137D-1/, V(203)/2.4922535764115491D-2/
      DATA U(204)/7.4400029758359727D-1/, V(204)/2.6075235767565118D-2/
      DATA U(205)/7.1736518536209988D-1/, V(205)/2.7188227500486381D-2/
      DATA U(206)/6.8963764434202760D-1/, V(206)/2.8259816057276862D-2/
      DATA U(207)/6.6085989898611980D-1/, V(207)/2.9288369583267848D-2/
      DATA U(208)/6.3107577304687197D-1/, V(208)/3.0272321759557981D-2/
      DATA U(209)/6.0033062282975174D-1/, V(209)/3.1210174188114702D-2/
      DATA U(210)/5.6867126812270978D-1/, V(210)/3.2100498673487773D-2/
      DATA U(211)/5.3614592089713193D-1/, V(211)/3.2941939397645401D-2/
      DATA U(212)/5.0280411188878499D-1/, V(212)/3.3733214984611523D-2/
      DATA U(213)/4.6869661517054448D-1/, V(213)/3.4473120451753929D-2/
      DATA U(214)/4.3387537083175609D-1/, V(214)/3.5160529044747593D-2/
      DATA U(215)/3.9839340588196923D-1/, V(215)/3.5794393953416055D-2/
      DATA U(216)/3.6230475349948732D-1/, V(216)/3.6373749905835978D-2/
      DATA U(217)/3.2566437074770191D-1/, V(217)/3.6897714638276009D-2/
      DATA U(218)/2.8852805488451185D-1/, V(218)/3.7365490238730490D-2/
      DATA U(219)/2.5095235839227212D-1/, V(219)/3.7776364362001397D-2/
      DATA U(220)/2.1299450285766613D-1/, V(220)/3.8129711314477638D-2/
      DATA U(221)/1.7471229183264681D-1/, V(221)/3.8424993006959423D-2/
      DATA U(222)/1.3616402280914389D-1/, V(222)/3.8661759774076463D-2/
      DATA U(223)/9.7408398441584599D-2/, V(223)/3.8839651059051969D-2/
      DATA U(224)/5.8504437152420669D-2/, V(224)/3.8958395962769531D-2/
      DATA U(225)/1.9511383256793998D-2/, V(225)/3.9017813656306655D-2/
C  N=96.
      DATA U(226)/9.9968950388323077D-1/, V(226)/7.9679206555201243D-4/
      DATA U(227)/9.9836437586318168D-1/, V(227)/1.8539607889469217D-3/
      DATA U(228)/9.9598184298720929D-1/, V(228)/2.9107318179349464D-3/
      DATA U(229)/9.9254390032376262D-1/, V(229)/3.9645543384446867D-3/
      DATA U(230)/9.8805412632962380D-1/, V(230)/5.0142027429275177D-3/
      DATA U(231)/9.8251726356301468D-1/, V(231)/6.0585455042359617D-3/
      DATA U(232)/9.7593917458513647D-1/, V(232)/7.0964707911538653D-3/
      DATA U(233)/9.6832682846326421D-1/, V(233)/8.1268769256987592D-3/
      DATA U(234)/9.5968829144874254D-1/, V(234)/9.1486712307833866D-3/
      DATA U(235)/9.5003271778443764D-1/, V(235)/1.0160770535008416D-2/
      DATA U(236)/9.3937033975275522D-1/, V(236)/1.1162102099838499D-2/
      DATA U(237)/9.2771245672230869D-1/, V(237)/1.2151604671088320D-2/
      DATA U(238)/9.1507142312089807D-1/, V(238)/1.3128229566961573D-2/
      DATA U(239)/9.0146063531585234D-1/, V(239)/1.4090941772314861D-2/
      DATA U(240)/8.8689451740242042D-1/, V(240)/1.5038721026994938D-2/
      DATA U(241)/8.7138850590929650D-1/, V(241)/1.5970562902562291D-2/
      DATA U(242)/8.5495903343460146D-1/, V(242)/1.6885479864245172D-2/
      DATA U(243)/8.3762351122818712D-1/, V(243)/1.7782502316045261D-2/
      DATA U(244)/8.1940031073793168D-1/, V(244)/1.8660679627411467D-2/
      DATA U(245)/8.0030874413914082D-1/, V(245)/1.9519081140145022D-2/
      DATA U(246)/7.8036904386743322D-1/, V(246)/2.0356797154333325D-2/
      DATA U(247)/7.5960234117664750D-1/, V(247)/2.1172939892191299D-2/
      DATA U(248)/7.3803064374440013D-1/, V(248)/2.1966644438744349D-2/
      DATA U(249)/7.1567681234896763D-1/, V(249)/2.2737069658329374D-2/
      DATA U(250)/6.9256453664217156D-1/, V(250)/2.3483399085926220D-2/
      DATA U(251)/6.6871831004391615D-1/, V(251)/2.4204841792364691D-2/
      DATA U(252)/6.4416340378496712D-1/, V(252)/2.4900633222483610D-2/
      DATA U(253)/6.1892584012546857D-1/, V(253)/2.5570036005349361D-2/
      DATA U(254)/5.9303236477757208D-1/, V(254)/2.6212340735672414D-2/
      DATA U(255)/5.6651041856139717D-1/, V(255)/2.6826866725591762D-2/
      DATA U(256)/5.3938810832435744D-1/, V(256)/2.7412962726029243D-2/
      DATA U(257)/5.1169417715466767D-1/, V(257)/2.7970007616848334D-2/
      DATA U(258)/4.8345797392059636D-1/, V(258)/2.8497411065085386D-2/
      DATA U(259)/4.5470942216774301D-1/, V(259)/2.8994614150555237D-2/
      DATA U(260)/4.2547898840730055D-1/, V(260)/2.9461089958167906D-2/
      DATA U(261)/3.9579764982890860D-1/, V(261)/2.9896344136328386D-2/
      DATA U(262)/3.6569686147231364D-1/, V(262)/3.0299915420827594D-2/
      DATA U(263)/3.3520852289262542D-1/, V(263)/3.0671376123669149D-2/
      DATA U(264)/3.0436494435449635D-1/, V(264)/3.1010332586313837D-2/
      DATA U(265)/2.7319881259104914D-1/, V(265)/3.1316425596861356D-2/
      DATA U(266)/2.4174315616384001D-1/, V(266)/3.1589330770727167D-2/
      DATA U(267)/2.1003131046056720D-1/, V(267)/3.1828758894411006D-2/
      DATA U(268)/1.7809688236761860D-1/, V(268)/3.2034456231992663D-2/
      DATA U(269)/1.4597371465489694D-1/, V(269)/3.2206204794030251D-2/
      DATA U(270)/1.1369585011066592D-1/, V(270)/3.2343822568575928D-2/
      DATA U(271)/8.1297495464425559D-2/, V(271)/3.2447163714064269D-2/
      DATA U(272)/4.8812985136049731D-2/, V(272)/3.2516118713868836D-2/
      DATA U(273)/1.6276744849602970D-2/, V(273)/3.2550614492363166D-2/

      IF(KTBA(MIN(MAX(1,N),97)) .EQ. 0) THEN
       X(1)=0
       WRITE(ERRTXT,101) N
       CALL MTLPRT(NAME(MODE),'D107.1',ERRTXT)
       RETURN
      ENDIF
      ALFA=HF*(B+A)
      BETA=HF*(B-A)
      IF(MODE .EQ. 1) THEN
       SUM=0
       J1=MOD(N,2)
       J2=KTBA(N)+(N-1)/2
       DO 1 J = KTBA(N),J2-J1
       DELTA=BETA*U(J)
       SUM=SUM+V(J)*(F(ALFA+DELTA)+F(ALFA-DELTA))
    1  CONTINUE
       IF(J1 .EQ. 1) SUM=SUM+V(J2)*F(ALFA)
       X(1)=BETA*SUM
      ELSE
       J1=KTBA(N)-1
       J2=N+1
       DO 2 J=1,J2/2
       WTEMP=BETA*V(J1+J)
       DELTA=BETA*U(J1+J)
       X(J)=ALFA-DELTA
       W(J)=WTEMP
       X(J2-J)=ALFA+DELTA
       W(J2-J)=WTEMP
    2  CONTINUE
      ENDIF
      RETURN
  101 FORMAT('N = ',I5,' IS NON-PERMISSIBLE')
      END
CDECK  ID>, TRAPER. 
      SUBROUTINE TRAPER (X,Y,E,N,AA,BB,RE,SD)
      DIMENSION X(N),Y(N),E(N)
      RE=0.
      SD=0.
      IF(AA .EQ. BB .OR. N .LT. 2) RETURN
      A=AA
      B=BB
      IF(AA .LT. BB) GO TO 1
      A=BB
      B=AA
    1 DO 40 I1 = 2,N
      I=I1
      IF(X(I) .GE. A) GO TO 41
   40 CONTINUE
   41 DO 42 J1 = 2,N
      J=J1
      IF(X(J) .GE. B) GO TO 43
   42 CONTINUE
   43 WI1=(X(I)-A)**2/(X(I)-X(I-1))
      WI=(1.0+(A-X(I-1))/(X(I)-X(I-1)))*(X(I)-A)
      WJ1=(1.0+(X(J)-B)/(X(J)-X(J-1)))*(B-X(J-1))
      WJ=(B-X(J-1))**2/(X(J)-X(J-1))
      IF(I .NE. J) GO TO 2
      WI1=WI1+WJ1+X(I-1)-X(I)
      WI=WI+WJ+X(I-1)-X(I)
      WJ1=0.
      WJ=0.
      GO TO 10
    2 IF(I .NE. J-1) GO TO 3
      WI=WI+WJ1
      WJ1=0.
      GO TO 10
    3 WI=WI+X(I+1)-X(I)
      WJ1=WJ1+X(J-1)-X(J-2)
      IF(I .EQ. J-2) GO TO 10
      LI=I+1
      LJ=J-2
      DO 4 L = LI,LJ
      RE=RE+(X(L+1)-X(L-1))*Y(L)
    4 SD=SD+((X(L+1)-X(L-1))*E(L))**2
   10 RE=RE+WI1*Y(I-1)+WI*Y(I)+WJ1*Y(J-1)+WJ*Y(J)
      SD=SD+(WI1*E(I-1))**2+(WI*E(I))**2+(WJ1*E(J-1))**2+(WJ*E(J))**2
      RE=0.5*RE
      SD=0.5*SQRT(SD)
      IF(AA .GT. BB) RE=-RE
      RETURN
      END
CDECK  ID>, RGMLT.  
      FUNCTION RGMLT1(FSUB1,A,B,NI,NG,X)

      ENTRY RGMLT2(FSUB2,A,B,NI,NG,X)
      ENTRY RGMLT3(FSUB3,A,B,NI,NG,X)
      ENTRY RGMLT4(FSUB4,A,B,NI,NG,X)
      ENTRY RGMLT5(FSUB5,A,B,NI,NG,X)
      ENTRY RGMLT6(FSUB6,A,B,NI,NG,X)

C
      CHARACTER NAME*(*)
      PARAMETER (NAME = 'RGMLT')
      CALL MTLPRT(NAME,'D110.0','Not available on this machine')
      RGMLT1=0
      RETURN
      END
CDECK  ID>, RGMLT64.
      FUNCTION DGMLT1(FSUB1,A,B,NI,NG,X)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      CHARACTER NAME*(*)
      CHARACTER*80 ERRTXT
      PARAMETER (NAME = 'DGMLT1')
      PARAMETER (Z1 = 1, HALF = Z1/2)

      DIMENSION X(6),W(14),T(14),V(64),U(64),F(64)

      DATA (T(I),W(I),I=1,14)
     1/-0.93246 95142 03152 028D0, 0.17132 44923 79170 345D0,
     2 -0.66120 93864 66264 514D0, 0.36076 15730 48138 608D0,
     3 -0.23861 91860 83196 909D0, 0.46791 39345 72691 047D0,
     4  0.23861 91860 83196 909D0, 0.46791 39345 72691 047D0,
     5  0.66120 93864 66264 514D0, 0.36076 15730 48138 608D0,
     6  0.93246 95142 03152 028D0, 0.17132 44923 79170 345D0,
     7 -0.96028 98564 97536 232D0, 0.10122 85362 90376 259D0,
     8 -0.79666 64774 13626 740D0, 0.22238 10344 53374 471D0,
     9 -0.52553 24099 16328 986D0, 0.31370 66458 77887 287D0,
     A -0.18343 46424 95649 805D0, 0.36268 37833 78361 983D0,
     B  0.18343 46424 95649 805D0, 0.36268 37833 78361 983D0,
     C  0.52553 24099 16328 986D0, 0.31370 66458 77887 287D0,
     D  0.79666 64774 13626 740D0, 0.22238 10344 53374 471D0,
     E  0.96028 98564 97536 232D0, 0.10122 85362 90376 259D0/

      IF(NI .LE. 0) THEN
       WRITE(ERRTXT,101) NI
       CALL MTLPRT(NAME,'D110.1',ERRTXT)
       STOP
      END IF
      M0=NG
      IF(M0 .NE. 8) M0=6
      I0=0
      IF(M0 .EQ. 8) I0=6
      D=(B-A)/NI
      R=HALF*D
      RA=R+A
      MV=MOD(M0*NI-1,64)+1
      S=0
      J=0
      DO 1 I = 1+I0,M0+I0
      RTA=R*T(I)+RA
      DO 2 K = 1,NI
      J=J+1
      V(J)=W(I)
      U(J)=RTA+(K-1)*D
      IF(J .EQ. MV) THEN
       CALL FSUB1(MV,U,F,X)
       DO 3 J = 1,MV
    3  S=S+V(J)*F(J)
       MV=64
       J=0
      END IF
    2 CONTINUE
    1 CONTINUE
      DGMLT1=R*S
      RETURN
  101 FORMAT('N1 = ',I4,' <= 0')
      END
      FUNCTION DGMLT2(FSUB2,A,B,NI,NG,X)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      CHARACTER NAME*(*)
      CHARACTER*80 ERRTXT
      PARAMETER (NAME = 'DGMLT2')
      PARAMETER (Z1 = 1, HALF = Z1/2)

       DIMENSION X(6),W(14),T(14),V(64),U(64),F(64)

      DATA (T(I),W(I),I=1,14)
     1/-0.93246 95142 03152 028D0, 0.17132 44923 79170 345D0,
     2 -0.66120 93864 66264 514D0, 0.36076 15730 48138 608D0,
     3 -0.23861 91860 83196 909D0, 0.46791 39345 72691 047D0,
     4  0.23861 91860 83196 909D0, 0.46791 39345 72691 047D0,
     5  0.66120 93864 66264 514D0, 0.36076 15730 48138 608D0,
     6  0.93246 95142 03152 028D0, 0.17132 44923 79170 345D0,
     7 -0.96028 98564 97536 232D0, 0.10122 85362 90376 259D0,
     8 -0.79666 64774 13626 740D0, 0.22238 10344 53374 471D0,
     9 -0.52553 24099 16328 986D0, 0.31370 66458 77887 287D0,
     A -0.18343 46424 95649 805D0, 0.36268 37833 78361 983D0,
     B  0.18343 46424 95649 805D0, 0.36268 37833 78361 983D0,
     C  0.52553 24099 16328 986D0, 0.31370 66458 77887 287D0,
     D  0.79666 64774 13626 740D0, 0.22238 10344 53374 471D0,
     E  0.96028 98564 97536 232D0, 0.10122 85362 90376 259D0/

      IF(NI .LE. 0) THEN
       WRITE(ERRTXT,101) NI
       CALL MTLPRT(NAME,'D110.1',ERRTXT)
      END IF
      M0=NG
      IF(M0 .NE. 8) M0=6
      I0=0
      IF(M0 .EQ. 8) I0=6
      D=(B-A)/NI
      R=HALF*D
      RA=R+A
      MV=MOD(M0*NI-1,64)+1
      S=0
      J=0
      DO 1 I = 1+I0,M0+I0
      RTA=R*T(I)+RA
      DO 2 K = 1,NI
      J=J+1
      V(J)=W(I)
      U(J)=RTA+(K-1)*D
      IF(J .EQ. MV) THEN
       CALL FSUB2(MV,U,F,X)
       DO 3 J = 1,MV
    3  S=S+V(J)*F(J)
       MV=64
       J=0
      END IF
    2 CONTINUE
    1 CONTINUE
      DGMLT2=R*S
      RETURN
  101 FORMAT('N2 = ',I4,' <= 0')
      END
      FUNCTION DGMLT3(FSUB3,A,B,NI,NG,X)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      CHARACTER NAME*(*)
      CHARACTER*80 ERRTXT
      PARAMETER (NAME = 'DGMLT3')
      PARAMETER (Z1 = 1, HALF = Z1/2)

      DIMENSION X(6),W(14),T(14),V(64),U(64),F(64)

      DATA (T(I),W(I),I=1,14)
     1/-0.93246 95142 03152 028D0, 0.17132 44923 79170 345D0,
     2 -0.66120 93864 66264 514D0, 0.36076 15730 48138 608D0,
     3 -0.23861 91860 83196 909D0, 0.46791 39345 72691 047D0,
     4  0.23861 91860 83196 909D0, 0.46791 39345 72691 047D0,
     5  0.66120 93864 66264 514D0, 0.36076 15730 48138 608D0,
     6  0.93246 95142 03152 028D0, 0.17132 44923 79170 345D0,
     7 -0.96028 98564 97536 232D0, 0.10122 85362 90376 259D0,
     8 -0.79666 64774 13626 740D0, 0.22238 10344 53374 471D0,
     9 -0.52553 24099 16328 986D0, 0.31370 66458 77887 287D0,
     A -0.18343 46424 95649 805D0, 0.36268 37833 78361 983D0,
     B  0.18343 46424 95649 805D0, 0.36268 37833 78361 983D0,
     C  0.52553 24099 16328 986D0, 0.31370 66458 77887 287D0,
     D  0.79666 64774 13626 740D0, 0.22238 10344 53374 471D0,
     E  0.96028 98564 97536 232D0, 0.10122 85362 90376 259D0/

      IF(NI .LE. 0) THEN
       WRITE(ERRTXT,101) NI
       CALL MTLPRT(NAME,'D110.1',ERRTXT)
       STOP
      END IF
      M0=NG
      IF(M0 .NE. 8) M0=6
      I0=0
      IF(M0 .EQ. 8) I0=6
      D=(B-A)/NI
      R=HALF*D
      RA=R+A
      MV=MOD(M0*NI-1,64)+1
      S=0
      J=0
      DO 1 I = 1+I0,M0+I0
      RTA=R*T(I)+RA
      DO 2 K = 1,NI
      J=J+1
      V(J)=W(I)
      U(J)=RTA+(K-1)*D
      IF(J .EQ. MV) THEN
       CALL FSUB3(MV,U,F,X)
       DO 3 J = 1,MV
    3  S=S+V(J)*F(J)
       MV=64
       J=0
      END IF
    2 CONTINUE
    1 CONTINUE
      DGMLT3=R*S
      RETURN
  101 FORMAT('N3 = ',I4,' <= 0')
      END
      FUNCTION DGMLT4(FSUB4,A,B,NI,NG,X)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      CHARACTER NAME*(*)
      CHARACTER*80 ERRTXT
      PARAMETER (NAME = 'DGMLT4')
      PARAMETER (Z1 = 1, HALF = Z1/2)

      DIMENSION X(6),W(14),T(14),V(64),U(64),F(64)

      DATA (T(I),W(I),I=1,14)
     1/-0.93246 95142 03152 028D0, 0.17132 44923 79170 345D0,
     2 -0.66120 93864 66264 514D0, 0.36076 15730 48138 608D0,
     3 -0.23861 91860 83196 909D0, 0.46791 39345 72691 047D0,
     4  0.23861 91860 83196 909D0, 0.46791 39345 72691 047D0,
     5  0.66120 93864 66264 514D0, 0.36076 15730 48138 608D0,
     6  0.93246 95142 03152 028D0, 0.17132 44923 79170 345D0,
     7 -0.96028 98564 97536 232D0, 0.10122 85362 90376 259D0,
     8 -0.79666 64774 13626 740D0, 0.22238 10344 53374 471D0,
     9 -0.52553 24099 16328 986D0, 0.31370 66458 77887 287D0,
     A -0.18343 46424 95649 805D0, 0.36268 37833 78361 983D0,
     B  0.18343 46424 95649 805D0, 0.36268 37833 78361 983D0,
     C  0.52553 24099 16328 986D0, 0.31370 66458 77887 287D0,
     D  0.79666 64774 13626 740D0, 0.22238 10344 53374 471D0,
     E  0.96028 98564 97536 232D0, 0.10122 85362 90376 259D0/

      IF(NI .LE. 0) THEN
       WRITE(ERRTXT,101) NI
       CALL MTLPRT(NAME,'D110.1',ERRTXT)
       STOP
      END IF
      M0=NG
      IF(M0 .NE. 8) M0=6
      I0=0
      IF(M0 .EQ. 8) I0=6
      D=(B-A)/NI
      R=HALF*D
      RA=R+A
      MV=MOD(M0*NI-1,64)+1
      S=0
      J=0
      DO 1 I = 1+I0,M0+I0
      RTA=R*T(I)+RA
      DO 2 K = 1,NI
      J=J+1
      V(J)=W(I)
      U(J)=RTA+(K-1)*D
      IF(J .EQ. MV) THEN
       CALL FSUB4(MV,U,F,X)
       DO 3 J = 1,MV
    3  S=S+V(J)*F(J)
       MV=64
       J=0
      END IF
    2 CONTINUE
    1 CONTINUE
      DGMLT4=R*S
      RETURN
  101 FORMAT('N4 = ',I4,' <= 0')
      END
      FUNCTION DGMLT5(FSUB5,A,B,NI,NG,X)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      CHARACTER NAME*(*)
      CHARACTER*80 ERRTXT
      PARAMETER (NAME = 'DGMLT5')
      PARAMETER (Z1 = 1, HALF = Z1/2)

      DIMENSION X(6),W(14),T(14),V(64),U(64),F(64)

      DATA (T(I),W(I),I=1,14)
     1/-0.93246 95142 03152 028D0, 0.17132 44923 79170 345D0,
     2 -0.66120 93864 66264 514D0, 0.36076 15730 48138 608D0,
     3 -0.23861 91860 83196 909D0, 0.46791 39345 72691 047D0,
     4  0.23861 91860 83196 909D0, 0.46791 39345 72691 047D0,
     5  0.66120 93864 66264 514D0, 0.36076 15730 48138 608D0,
     6  0.93246 95142 03152 028D0, 0.17132 44923 79170 345D0,
     7 -0.96028 98564 97536 232D0, 0.10122 85362 90376 259D0,
     8 -0.79666 64774 13626 740D0, 0.22238 10344 53374 471D0,
     9 -0.52553 24099 16328 986D0, 0.31370 66458 77887 287D0,
     A -0.18343 46424 95649 805D0, 0.36268 37833 78361 983D0,
     B  0.18343 46424 95649 805D0, 0.36268 37833 78361 983D0,
     C  0.52553 24099 16328 986D0, 0.31370 66458 77887 287D0,
     D  0.79666 64774 13626 740D0, 0.22238 10344 53374 471D0,
     E  0.96028 98564 97536 232D0, 0.10122 85362 90376 259D0/

      IF(NI .LE. 0) THEN
       WRITE(ERRTXT,101) NI
       CALL MTLPRT(NAME,'D110.1',ERRTXT)
       STOP
      END IF
      M0=NG
      IF(M0 .NE. 8) M0=6
      I0=0
      IF(M0 .EQ. 8) I0=6
      D=(B-A)/NI
      R=HALF*D
      RA=R+A
      MV=MOD(M0*NI-1,64)+1
      S=0
      J=0
      DO 1 I = 1+I0,M0+I0
      RTA=R*T(I)+RA
      DO 2 K = 1,NI
      J=J+1
      V(J)=W(I)
      U(J)=RTA+(K-1)*D
      IF(J .EQ. MV) THEN
       CALL FSUB5(MV,U,F,X)
       DO 3 J = 1,MV
    3  S=S+V(J)*F(J)
       MV=64
       J=0
      END IF
    2 CONTINUE
    1 CONTINUE
      DGMLT5=R*S
      RETURN
  101 FORMAT('N5 = ',I4,' <= 0')
      END
      FUNCTION DGMLT6(FSUB6,A,B,NI,NG,X)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      CHARACTER NAME*(*)
      CHARACTER*80 ERRTXT
      PARAMETER (NAME = 'DGMLT6')
      PARAMETER (Z1 = 1, HALF = Z1/2)

      DIMENSION X(6),W(14),T(14),V(64),U(64),F(64)

      DATA (T(I),W(I),I=1,14)
     1/-0.93246 95142 03152 028D0, 0.17132 44923 79170 345D0,
     2 -0.66120 93864 66264 514D0, 0.36076 15730 48138 608D0,
     3 -0.23861 91860 83196 909D0, 0.46791 39345 72691 047D0,
     4  0.23861 91860 83196 909D0, 0.46791 39345 72691 047D0,
     5  0.66120 93864 66264 514D0, 0.36076 15730 48138 608D0,
     6  0.93246 95142 03152 028D0, 0.17132 44923 79170 345D0,
     7 -0.96028 98564 97536 232D0, 0.10122 85362 90376 259D0,
     8 -0.79666 64774 13626 740D0, 0.22238 10344 53374 471D0,
     9 -0.52553 24099 16328 986D0, 0.31370 66458 77887 287D0,
     A -0.18343 46424 95649 805D0, 0.36268 37833 78361 983D0,
     B  0.18343 46424 95649 805D0, 0.36268 37833 78361 983D0,
     C  0.52553 24099 16328 986D0, 0.31370 66458 77887 287D0,
     D  0.79666 64774 13626 740D0, 0.22238 10344 53374 471D0,
     E  0.96028 98564 97536 232D0, 0.10122 85362 90376 259D0/

      IF(NI .LE. 0) THEN
       WRITE(ERRTXT,101) NI
       CALL MTLPRT(NAME,'D110.1',ERRTXT)
       STOP
      END IF
      M0=NG
      IF(M0 .NE. 8) M0=6
      I0=0
      IF(M0 .EQ. 8) I0=6
      D=(B-A)/NI
      R=HALF*D
      RA=R+A
      MV=MOD(M0*NI-1,64)+1
      S=0
      J=0
      DO 1 I = 1+I0,M0+I0
      RTA=R*T(I)+RA
      DO 2 K = 1,NI
      J=J+1
      V(J)=W(I)
      U(J)=RTA+(K-1)*D
      IF(J .EQ. MV) THEN
       CALL FSUB6(MV,U,F,X)
       DO 3 J = 1,MV
    3  S=S+V(J)*F(J)
       MV=64
       J=0
      END IF
    2 CONTINUE
    1 CONTINUE
      DGMLT6=R*S
      RETURN
  101 FORMAT('N6 = ',I4,' <= 0')
      END
CDECK  ID>, GPINDP. 
      DOUBLE PRECISION FUNCTION GPINDP(A,B,EPSIN,EPSOUT,FUNC,IOP)
C
C     PARAMETERS
C
C     A       = LOWER BOUNDARY
C     B       = UPPER BOUNDARY
C     EPSIN   = ACCURACY REQUIRED FOR THE APPROXINATION
C     EPSOUT  = IMPROVED ERROR ESTIMATE FOR THE APPROXIMATION
C     FUNC    = FUNCTION ROUTINE FOR THE FUNCTION FUNC(X).TO BE DE-
C               CLARED EXTERNAL IN THE CALLING ROUTINE
C     IOP     = OPTION PARAMETER , IOP=1 , MODIFIED ROMBERG ALGORITHM,
C                                          ORDINARY CASE
C                                  IOP=2 , MODIFIED ROMBERG ALGORITHM,
C                                          COSINE TRANSFORMED CASE
C                                  IOP=3 , MODIFIED CLENSHAW-CURTIS AL
C                                          GORITHM
C
C     PARAMETERS IN COMMON BLOCK / GPINT /
C
C     TEND    = UPPER BOUND FOR VALUE OF INTEGRAL
C     UMID    = LOWER BOUND FOR VALUE OF INTEGRALC
C     N       = THE NUMBER OF INTEGRAND VALUES USED IN THE CALCULATION
C     LINE    = LINE NO IN ROMBERG TABLE (RELATED TO N THROUGH
C               N-1=2**(LINE-1) , APPLICABLE ONLY FOR IOP=1 OR 2)
C     IOUT    = ELEMENT NO IN LINE (APPLICABLE ONLY FOR IOP=1 OR 2)
C     JOP     = OPTION PARAMETER , JOP=0 , NO PRINTING OF INTERMEDIATE
C                                          CALCULATIONS
C                                  JOP=1 , PRINT INTERMEDIATE CALCULA-
C                                          TIONS
C     KOP     = OPTION PARAMETER , KOP=0 , NO TIME ESTIMATE
C                                  KOP=1 , ESTIMATE TIME
C     T       = TIME USED FOR CALCULATION IN MSEC.
C
C     INTEGRATION PARAMETERS
C
C     NUPPER  = 9 , CORRESPONDS TO 1024 SUB-INTERVALS FOR THE UNFOLDED
C               INTEGRAL.THE MAX.NO OF FUNCTION EVALUATIONS THUS BEEING
C               1025.THE HIGHEST END-POINT APPROXIMATION IS THUS USING
C               1024 INTERVALS WHILE THE HIGHEST MID-POINT APPROXIMA-
C               TION IS USING 512 INTERVALS.
C
C     INPUT/OUTPUT PARAMETERS
C
      EXTERNAL FUNC
      DOUBLE PRECISION A,B,EPSIN,EPSOUT,BOUND,FUNC
C
C     INTERNAL ARRAYS
C
      DOUBLE PRECISION ACOF(513),BCOF(513),CCOF(1025)
C
C     CONSTANTS IN DATA STATEMENTS
C
C*NS  DOUBLE PRECISION ZERO,FOURTH,HALF,ONE,TWO,THREE,FOUR,FAC1,FAC2,PI,
C*NS 1RANDER
      DOUBLE PRECISION ZERO,FOURTH,HALF,ONE,TWO,      FOUR,FAC1,FAC2,PI
C
C     VARIABLES DEPENDING ON STEPSIZE
C
      DOUBLE PRECISION ALF,BET,RN,HNSTEP,TEND,UMID,WMEAN,DELN,TNEW,AR
C
C     CONSTANTS RELATED TO CALCULATION OF TRIGONOMETRIC FUNCTIONS
C
      DOUBLE PRECISION TRIARG,ALFN0,BETN0,GAMMAN,DELTAN,ALFNJ,BETNJ,ETAN
     1K,KSINK
C
C     OTHER VARIABLES USED
C
C*NS  DOUBLE PRECISION CONST1,CONST2,XPLUS,XMIN,ERROR,RK,A0,A1,A2,COF,FA
C*NS 1CTOR,ENDPTS
      DOUBLE PRECISION CONST1,CONST2,XPLUS,XMIN,      RK,A0,A1,A2,COF,FA
     1CTOR,ENDPTS
C
      COMMON /GPINT/ TEND, UMID, N, LINE, IOUT, JOP, KOP, T
      DATA ZERO,FOURTH,HALF,ONE,TWO,FOUR/0.D0,.25D0,.5D0,1.D0,2.D0,4.D0/
      DATA PI,FAC1,FAC2/3.141592653589793238462643383279D0,.411233516712
     1056609118103791649D0,.822467033424113218236207583298D0/
C
      DATA NUPPER/9/
C
C     TIMEX(T) IS A LIBRARY SUBROUTINE GIVING THE ELAPSED CP TIME
C
      IF(KOP .NE. 0)  CALL TIMEX ( T1)
C
C     INITIAL CALCULATIONS
C
      ALF=HALF*(B-A)
      BET=HALF*(B+A)
      CONST1=FUNC(A)+FUNC(B)
      CONST2=FUNC(BET)
      HNSTEP=TWO
      IF(IOP.EQ.2) HNSTEP=PI
C
      IF(IOP.GT.1) GOTO 10
C
C     MODIFIED ROMBERG ALGORITHM,ORDINARY CASE
C
      BCOF(1)=HNSTEP*CONST2
      ACOF(1)=HALF*(CONST1+BCOF(1))
      FACTOR=ONE
      ACOF(2)=ACOF(1)-(ACOF(1)-BCOF(1))/(FOUR*FACTOR-ONE)
      GOTO 30
C
10    IF(IOP.GT.2) GOTO 20
C
C     MODIFIED ROMBERG ALGORITHM,COSINE TRANSFORMED CASE
C
      AR=FAC1
      ENDPTS=CONST1
      ACOF(1)=FAC2*CONST1
      BCOF(1)=HNSTEP*CONST2-AR*CONST1
      FACTOR=FOUR
      ACOF(1)=HALF*(ACOF(1)+BCOF(1))
      ACOF(2)=ACOF(1)-(ACOF(1)-BCOF(1))/(FOUR*FACTOR-ONE)
      AR=FOURTH*AR
      GOTO 30
C
20    CONST1=HALF*CONST1
      ACOF(1)=HALF*(CONST1+CONST2)
      ACOF(2)=HALF*(CONST1-CONST2)
      BCOF(2)=ACOF(2)
      TEND=TWO*(ACOF(1)-ACOF(2)/(ONE+TWO))
C
C     MODIFIED CLENSHAW-CURTIS ALGORITHM
C
30    HNSTEP=HALF*HNSTEP
      NHALF=1
      N=2
      RN=TWO
C
      IF(IOP.NE.1) THEN
C
C     INITIAL PARAMETERS SPECIAL FOR THE MODIFIED ROMBERG ALGORITHM,
C     COSINE TRANSFORMED CASE AND THE MODIFIED CLENSHAW-CURTIS ALGORITHM
C
        TRIARG=FOURTH*PI
        ALFN0=-ONE
      ENDIF
C
C     END OF INITIAL CALCULATIONS
C
C     START ACTUAL CALCULATION
C
C---  Transform this DO-loop into a GOTO to avoid illegal jumps into it
C
C     DO 350 I=1,NUPPER
      I=0
41    I=I+1
      IF(I.GT.NUPPER) GOTO 350
      LINE=I+2
C
      IF(IOP.GT.1) GOTO 60
C
C     MODIFIED ROMBERG ALGORITHM,ORDINARY CASE
C
C     COMPUTE FIRST ELEMENT IN MID-POINT FORMULA FOR ORDINARY CASE
C
      UMID=ZERO
      ALFNJ=HALF*HNSTEP
      DO 50 J=1,NHALF
      XPLUS=ALF*ALFNJ+BET
      XMIN=-ALF*ALFNJ+BET
      UMID=UMID+FUNC(XPLUS)+FUNC(XMIN)
      ALFNJ=ALFNJ+HNSTEP
50    CONTINUE
      UMID=HNSTEP*UMID
      GOTO 100
C
C     COMPUTE FUNCTION VALUES FOR MODIFIED ROMBERG ALGORITHM,COSINE
C     TRANSFORMED CASE AND MODIFIED CLENSHAW-CURTIS ALGORITHM
C
60    CONST1=-SIN(TRIARG)
      CONST2=HALF*ALFN0/CONST1
      IF(IOP.EQ.2) ETANK=CONST2
      ALFN0=CONST1
      BETN0=CONST2
      GAMMAN=ONE-TWO*ALFN0**2
      DELTAN=-TWO*ALFN0*BETN0
C
      DO 70 J=1,NHALF
      ALFNJ=GAMMAN*CONST1+DELTAN*CONST2
      BETNJ=GAMMAN*CONST2-DELTAN*CONST1
      XPLUS=ALF*ALFNJ+BET
      XMIN=-ALF*ALFNJ+BET
      CCOF(J)=FUNC(XPLUS)+FUNC(XMIN)
      CONST1=ALFNJ
      CONST2=BETNJ
70    CONTINUE
C
      IF(IOP.EQ.3) GOTO 190
C
C     COMPUTE FIRST ELEMENT IN MID-POINT FORMULA FOR COSINE TRANSFORMED
C     ROMBERG ALGORITHM
C
      NCOF=NHALF-1
      COF=TWO*(TWO*ETANK**2-ONE)
      A2=ZERO
      A1=ZERO
      A0=CCOF(NHALF)
      IF(NCOF.EQ.0) GOTO 90
      DO 80 J=1,NCOF
      A2=A1
      A1=A0
      INDEX=NHALF-J
      A0=CCOF(INDEX)+COF*A1-A2
80    CONTINUE
90    UMID=HNSTEP*(A0-A1)*ETANK-AR*ENDPTS
      AR=FOURTH*AR
C
C     MODIFIED ROMBERG ALGORITHM,CALCULATE (I+1)-TH ROW IN U-TABLE
C
100   CONST1=FOUR*FACTOR
      INDEX=I+1
      DO 110 J=2,INDEX
      TEND=UMID+(UMID-BCOF(J-1))/(CONST1-ONE)
      BCOF(J-1)=UMID
      UMID=TEND
      CONST1=FOUR*CONST1
110   CONTINUE
      BCOF(INDEX)=TEND
      XPLUS=CONST1
C
C     CALCULATION OF (I+1)-TH ROW IN U-TABLE FINISHED
C
C     PRINT INTERMEDIATE RESULTS IF WANTED
C
      IF(JOP.EQ.0) GOTO 120
C
      ICHECK=0
      ASSIGN 120 TO JUMP
      GOTO 360
C
C     TEST IF REQUIRED ACCURACY IS OBTAINED
C
120   EPSOUT=ONE
      IOUT=1
      DO 140 J=1,INDEX
      CONST1=HALF*(ACOF(J)+BCOF(J))
      CONST2=HALF*ABS((ACOF(J)-BCOF(J))/CONST1)
      IF(CONST2.GT.EPSOUT) GOTO 130
      EPSOUT=CONST2
      IOUT=J
130   ACOF(J)=CONST1
140   CONTINUE
C
C     TESTING ON ACCURACY FINISHED
C
      IF(IOUT.EQ.INDEX) IOUT=IOUT+1
      ACOF(INDEX+1)=ACOF(INDEX)-(ACOF(INDEX)-BCOF(INDEX))/(XPLUS-ONE)
C
      IF(EPSOUT.GT.EPSIN) GOTO 340
C
C     CALCULATION FOR MODIFIED ROMBERG ALGORITHM FINISHED
C
150   N=2*N
C
C     PRINT INTERMEDIATE RESULTS IF WANTED
C
      IF(JOP.EQ.0) GOTO 170
C
      ICHECK=1
      INDEX=INDEX+1
      ASSIGN 160 TO JUMP
      GOTO 360
C
160   INDEX=INDEX-1
C
170   N=N+1
      J=IOUT
      IF((J-1).LT.INDEX) GOTO 180
      J=INDEX
180   TEND=ALF*(TWO*ACOF(J)-BCOF(J))
      UMID=ALF*BCOF(J)
      GPINDP=ALF*ACOF(IOUT)
C
      GOTO 310
C
C     START CALCULATION FOR MODIFIED CLENSHAW-CURTIS ALGORITHM
C
190   BCOF(1)=ZERO
      DO 200 J=1,NHALF
      BCOF(1)=BCOF(1)+CCOF(J)
200   CONTINUE
      BCOF(1)=HALF*HNSTEP*BCOF(1)
C
C     CALCULATION OF FIRST B-COEFFICIENT FINISHED.COMPUTE THE HIGHER
C     COEFFICIENTS IF NHALF GREATER THAN ONE
C
      IF(NHALF.EQ.1) GOTO 230
C
      CONST1=ONE
      CONST2=ZERO
      NCOF=NHALF-1
      KSIGN=-1
      DO 220 K=1,NCOF
C
C     COMPUTE TRIGONOMETRIC SUM FOR B-COEFFICIENT
C
      ETANK=GAMMAN*CONST1-DELTAN*CONST2
      KSINK=GAMMAN*CONST2+DELTAN*CONST1
      COF=TWO*(TWO*ETANK**2-ONE)
      A2=ZERO
      A1=ZERO
      A0=CCOF(NHALF)
      DO 210 J=1,NCOF
      A2=A1
      A1=A0
      INDEX=NHALF-J
      A0=CCOF(INDEX)+COF*A1-A2
210   CONTINUE
C
      BCOF(K+1)=HNSTEP*(A0-A1)*ETANK
      IF(KSIGN.EQ.-1) BCOF(K+1)=-BCOF(K+1)
      KSIGN=-KSIGN
C
      CONST1=ETANK
      CONST2=KSINK
C
220   CONTINUE
C
C     CALCULATION OF B-COEFFICIENTS FINISHED
C
C     COMPUTE NEW MODIFIED MID-POINT APPROXIMATION WHEN THE INTERVAL
C     OF INTEGRATION IS DIVIDED IN N EQUAL SUB INTERVALS
C
230   UMID=ZERO
      RK=RN
      NN=NHALF+1
      DO 240 K=1,NN
      INDEX=NN+1-K
      UMID=UMID+BCOF(INDEX)/(RK**2-ONE)
      RK=RK-TWO
240   CONTINUE
      UMID=-TWO*UMID
C
C     COMPUTE NEW C-COEFFICIENTS FOR END-POINT APPROXIMATION
C
      NN=N+2
      DO 250 J=1,NHALF
      INDEX=NN-J
      CCOF(J)=HALF*(ACOF(J)+BCOF(J))
      CCOF(INDEX)=HALF*(ACOF(J)-BCOF(J))
250   CONTINUE
      INDEX=NHALF+1
      CCOF(INDEX)=ACOF(INDEX)
C
C     CALCULATION OF NEW COEFFICIENTS FINISHED
C
C     COMPUTE NEW END-POINT APPROXIMATION WHEN THE INTERVAL OF INTEGRA-
C     TION IS DIVIDED IN 2N EQUAL SUB INTERVALS
C
      WMEAN=HALF*(TEND+UMID)
      BOUND=HALF*(TEND-UMID)
C
      DELN=ZERO
      RK=TWO*RN
      DO 260 J=1,NHALF
      INDEX=N+2-J
      DELN=DELN+CCOF(INDEX)/(RK**2-ONE)
      RK=RK-TWO
260   CONTINUE
      DELN=-TWO*DELN
C
C     PRINT INTERMEDIATE RESULTS IF WANTED
C
      IF(JOP.EQ.0) GOTO 270
C
      GOTO 400
C
C     PRINTING OF INTERMEDIATE RESULTS FINISHED
C
270   TNEW=WMEAN+DELN
      EPSOUT=ABS(BOUND/TNEW)
C
      IF(EPSOUT.GT.EPSIN) GOTO 320
C
C     REQUIRED ACCURACY OBTAINED
C
280   N=2*N+1
C
C*UL 290   TEND=ALF*(TEND+DELN)
      TEND=ALF*(TEND+DELN)
      UMID=ALF*(UMID+DELN)
C
C*UL 300   GPINDP=ALF*TNEW
      GPINDP=ALF*TNEW
C
310   IF(KOP.EQ.0) GOTO 315
      CALL TIMEX ( T)
      T=1000.*(T - T1)
C
 315  RETURN
C
320   DO 330 J=1,N
      ACOF(J)=CCOF(J)
330   CONTINUE
      ACOF(N+1)=CCOF(N+1)
      BCOF(N+1)=CCOF(N+1)
      TEND=TNEW
C
340   NHALF=N
      N=2*N
      RN=TWO*RN
      HNSTEP=HALF*HNSTEP
      IF(IOP.GT.1) TRIARG=HALF*TRIARG
C
      GOTO 41
350   CONTINUE
C
C     REQUIRED ACCURACY OF INTEGRAL NOT OBTAINED
C
      N=NHALF
      RN=HALF*RN
C
      IF(IOP.LT.3) GOTO 150
C
      TEND=TWO*(TNEW-DELN)-UMID
C
      GOTO 280
C     PRINT INTERMEDIATE RESULTS FOR THE MODIFIED ROMBERG ALGORITHM
C
360   IF((N.NE.2).AND.(N.NE.256)) GOTO 370
      IF(N.EQ.256) WRITE(6,460)
      WRITE(6,420)
370   DO 390 J=1,INDEX
      CONST1=ALF*ACOF(J)
      IF(ICHECK.EQ.1) GOTO 380
      CONST2=ALF*BCOF(J)
      IF(J.EQ.1) WRITE(6,430) N,J,CONST1,CONST2
      IF(J.GT.1) WRITE(6,440) J,CONST1,CONST2
      GOTO 390
C
380   IF(J.EQ.1) WRITE(6,430) N,J,CONST1
      IF(J.GT.1) WRITE(6,440) J,CONST1
390   CONTINUE
      GOTO JUMP,(120,160)
C
C     PRINTING FINISHED FOR THE MODIFIED ROMBERG ALGORITHM
C
C     PRINT INTERMEDIATE RESULTS FOR THE MODIFIED CLENSHAW-CURTIS AL-
C     GORITHM
C
400   A0=ALF*TEND
      A1=ALF*WMEAN
      A2=ALF*UMID
      CONST1=ALF*BOUND
      CONST2=ALF*DELN
C
      IF(N.GT.2) GOTO 410
C
      WRITE(6,470)
410   WRITE(6,480) N,A0
      WRITE(6,490) A1,CONST2,CONST1
      WRITE(6,490) A2
      GOTO 270
C
C     PRINTING FINISHED FOR THE MODIFIED CLENSHAW-CURTIS ALGORITHM
C
420   FORMAT(/,8X,'N',3X,'J',19X,'TEND(J)',34X,'UMID(J)',/)
430   FORMAT(5X,I4,2X,I2,4X,D36.29,5X,D36.29)
440   FORMAT(11X,I2,4X,D36.29,5X,D36.29)
450   FORMAT(/)
460   FORMAT('1'////)
470   FORMAT(6X,'N',17X,'TEND  ',/,20X,'(TEND+UMID)/2',28X,'DELN',34X,
     1 '(TEND-UMID)/2'/24X,'UMID')
480   FORMAT(/,4X,I3,2X,D36.29)
490   FORMAT(9X,D36.29,3X,D36.29,3X,D36.29)
      END
CDECK  ID>, CGAUSS. 
C This will be CGAUSS,IF=DOUBLE and CGAUSS64,IF=-DOUBLE.
      FUNCTION CGAUSS(F,A,B,EPS)
      COMPLEX CGAUSS,F,A,B,AA,BB,U,C1,C2,S8,S16,H
      CHARACTER NAME*(*)
      PARAMETER (NAME = 'CGAUSS')
      DIMENSION W(12),X(12)

      PARAMETER (Z1 = 1, HF = Z1/2, CST = 5*Z1/1000)

      DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
      DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
      DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
      DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
      DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
      DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
      DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
      DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
      DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
      DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
      DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
      DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/

      H=0
      IF(B .EQ. A) GO TO 99
      CONST=CST/ABS(B-A)
      BB=A
    1 AA=BB
      BB=B
    2 C1=HF*(BB+AA)
      C2=HF*(BB-AA)
      S8=0
      DO 3 I = 1,4
      U=C2*X(I)
    3 S8=S8+W(I)*(F(C1+U)+F(C1-U))
      S16=0
      DO 4 I = 5,12
      U=C2*X(I)
    4 S16=S16+W(I)*(F(C1+U)+F(C1-U))
      S16=C2*S16
      IF(ABS(S16-C2*S8) .LE. EPS*(1+ABS(S16))) THEN
       H=H+S16
       IF(BB .NE. B) GO TO 1
      ELSE
       BB=C1
       IF(1+CONST*ABS(C2) .NE. 1) GO TO 2
       H=0
       CALL MTLPRT(NAME,'D113.1','TOO HIGH ACCURACY REQUIRED')
       GO TO 99
      END IF
   99 CGAUSS=H
      RETURN
      END
CDECK  ID>, CGAUSS64.   
      FUNCTION WGAUSS(F,A,B,EPS)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMPLEX*16
     +     WGAUSS,F,A,B,AA,BB,U,C1,C2,S8,S16,H
      CHARACTER NAME*(*)
      PARAMETER (NAME = 'WGAUSS')
      DIMENSION W(12),X(12)

      PARAMETER (Z1 = 1, HF = Z1/2, CST = 5*Z1/1000)

      DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
      DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
      DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
      DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
      DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
      DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
      DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
      DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
      DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
      DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
      DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
      DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/

      H=0
      IF(B .EQ. A) GO TO 99
      CONST=CST/ABS(B-A)
      BB=A
    1 AA=BB
      BB=B
    2 C1=HF*(BB+AA)
      C2=HF*(BB-AA)
      S8=0
      DO 3 I = 1,4
      U=C2*X(I)
    3 S8=S8+W(I)*(F(C1+U)+F(C1-U))
      S16=0
      DO 4 I = 5,12
      U=C2*X(I)
    4 S16=S16+W(I)*(F(C1+U)+F(C1-U))
      S16=C2*S16
      IF(ABS(S16-C2*S8) .LE. EPS*(1+ABS(S16))) THEN
       H=H+S16
       IF(BB .NE. B) GO TO 1
      ELSE
       BB=C1
       IF(1+CONST*ABS(C2) .NE. 1) GO TO 2
       H=0
       CALL MTLPRT(NAME,'D113.1','TOO HIGH ACCURACY REQUIRED')
       GO TO 99
      END IF

   99 WGAUSS=H
      RETURN
      END
CDECK  ID>, RIWIAD. 
      SUBROUTINE RIWIAD(F)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C********** COMMUNICATION TO CALLING PROGRAM
C
      COMMON/PARAMS/ACC,NDIM,NSUB,ITER
      COMMON/ANSWER/VALUE,ERROR
      COMMON/STORE/XA(11),XB(11),XC(11),XD(11),MA(11),MB(11),MC(11)
      COMMON/STORE1/R(10000),LR
      COMMON/OPTION/IPRINT,ICONV,IRESET
      COMMON/RANDOM/NSHOTS
      COMMON/INTERN/FACTOR,ALFA,BETA,GAMMA,DELTA,LEVEL,NMIN
C*NS  INTEGER XLOC, FNAME
      EXTERNAL F
C
      REAL Q
C     MODIFICATIONS FOR DOUBLE PRECISION
      REAL(N)=DBLE(N)
C............
      CALL RIWIBD
C***************CONSTANTS AND COUNTERS
      ZERO=1.0E-12
      ONE=1.0-ZERO
      ITC=0
      NCALL=0
      SWI=0.0
      SRV=0.0
      SWISQ=0.0
      ANMIN=NMIN
      ANDIM=NDIM
      ANSUB=NSUB
      RNDIM=1.0/ANDIM
      ANSHT1=NSHOTS-1
      RNSHTS=1.0/NSHOTS
      RNSHT1=1.0/(NSHOTS-1)
C
C********** INITIALISE INTERVALS
C
      IF(MA(1).EQ.0) GOTO 201
      IF(IRESET.EQ.0) GOTO 202
  201 K=INT(ANSUB**RNDIM+ZERO)
      IF(K.LT.NMIN) GOTO 207
      A=1.0/K
      L=NDIM*K
      DO 204 I=1,L
  204 R(I)=A
      DO 203 I=1,NDIM
  203 MA(I)=K
  202 CONTINUE
C
C********** PRINT OUT INITIAL VALUES
C
      IF(IPRINT.EQ.0) GOTO 1
      WRITE(6,2)
    2 FORMAT('1........ RIEMANN INTEGRATION WITH INTERVAL ADJUSTMENT',
     *'........')
      WRITE(6,3)      ACC,NDIM,NSUB,ITER
3      FORMAT('0******** INPUT PARAM ********'//
     +,' NAME OF INTEGRAND...',13X,'F   '/
     +,' RELATIVE ACCURACY... ',12X,F7.5/
     +,' DIMENSION OF INTEGRAL... ',I15/
     +,' MAXIMUM NUMBER OF SUBVOLUMES... ',I8/
     +,' MAXIMUM NUMBER OF ITERATIONS... ',I8)
      IF(IPRINT.EQ.2) GOTO 1
      WRITE(6,4)NSHOTS,LEVEL,FACTOR,IPRINT,
     1ICONV,IRESET,ALFA,BETA,GAMMA,DELTA,NMIN
    4 FORMAT('0'/'0******** INTERNAL PARAMETERS ********'//
     +,' NUMBER OF CALLS PER SUBVOLUME... ',I7/
     +,' LEVEL OF CONFIDENCE (PER CENT)...',I7/
     +,' CORRESPONDING FACTOR...',F17.2/
     +,' PRINT OPTION...',I25/
     +,' CONVERGENCE CRITERION...',I16/
     +,' RESET OPTION...',I25/
     +,' RATE OF CONVERGENCE...',2X,4F4.2/
     +,' MINIMUM NUMBER OF INTERVALS...',I10)
C
C********** ENTRY AND REENTRY FOR ITERATIONS
C
    1 ITC=ITC+1
      J=1
      NID114=0
      DO 6 I=1,NDIM
      MB(I)=NID114
      K=MA(I)
      J=J*K
    6 NID114=NID114+K
      NCALL=NCALL+NSHOTS*J
      LA=0
      LB=NID114
      LC=2*NID114
      LD=3*NID114
      LE=4*NID114
      IF(LE.GT.LR) GOTO 107
C
C********** INITIALISE INTEGRATION LOOP
C
C*UL7 L=0
      L=0
      V=1.0
      DO 110 I=1,NDIM
      MC(I)=1
      K=L+1
      L=L+MA(I)
      A=R(LA+K)
      XA(I)=A
      XB(I)=0.0
      XC(I)=V
      V=V*A
      X=0.0
      DO 8 J=K,L
      R(LB+J)=X
      X=X+R(LA+J)
      R(LC+J)=0.0
    8 R(LD+J)=0.0
      R(LA+L)=R(LA+L)+1.0-X
  110 CONTINUE
C
C********** INTEGRATION LOOP
C
   15 SF1=0.0
      SF2=0.0
      DO 9 N=1,NSHOTS
      DO 10 I=1,NDIM
   10 XD(I)=XB(I)+XA(I)*RNDM(I)
      Y=F(XD)
      SF1=SF1+Y
    9 SF2=SF2+Y**2
      SF1=SF1*RNSHTS
      SF2=SF2*RNSHTS
      C=V*SF1
      D=V**2*(SF2-SF1**2)*RNSHT1
      DO 11 I=1,NDIM
      J=MB(I)+MC(I)
      R(LC+J)=R(LC+J)+C
   11 R(LD+J)=R(LD+J)+D
C
C********** LOOP THE LOOP
C
      I=NDIM
   13 J=MC(I)
      K=MB(I)+1
      IF(J.NE.MA(I)) GOTO 12
      MC(I)=1
      XA(I)=R(LA+K)
      XB(I)=0.0
      I=I-1
      IF(I) 14,14,13
   12 MC(I)=J+1
      V=XC(I)
      K=K+J
      A=R(LA+K)
      XA(I)=A
      XB(I)=R(LB+K)
      V=V*A
   16 IF(I.EQ.NDIM) GOTO 15
      I=I+1
      XC(I)=V
      V=V*XA(I)
      GOTO 16
C
C********** CALCULATE INTEGRAL AND ERROR
C
   14 J=MA(1)
      SI=0.0
      SV=0.0
      DO 17 I=1,J
      SI=SI+R(LC+I)
   17 SV=SV+R(LD+I)
      IF(SV.EQ.0.0) GOTO 400
      RV=1.0/SV
      WI=SI*RV
      SRV=SRV+RV
      SWI=SWI+WI
      VALUE=SWI/SRV
      FSV=FACTOR*SQRT(SV)
      ERROR=FACTOR/SQRT(SRV)
      SWISQ=SWISQ+RV*SI**2
      CHISQ=SWISQ-VALUE**2*SRV
C
C********** REDUCE TO RELATIVE QUANTITIES
C
      RI=1.0/SI
      DO 18 J=1,NID114
      R(LC+J)=R(LC+J)*RI
   18 R(LD+J)=R(LD+J)*RV
C
C********** PRINT OUT THE RESULTS OF THIS ITERATION
C
      IF(IPRINT.EQ.0) GOTO 25
      WRITE(6,20)ITC,SI,FSV,VALUE,ERROR,CHISQ
     1,NCALL,(MA(I),I=1,NDIM)
 20   FORMAT('0'//////' ******** ITERATION NUMBER',I3,' ********'//
     +,' VALUE OF INTEGRAL...',E13.5/
     +,' ESTIMATED ERROR.....',E13.5//
     +,' ACCUMULATED VALUE...',E13.5/
     +,' ACCUMULATED ERROR...',E13.5//
     +,' CHI SQUARE..........',F13.2//
     +,' NUMBER OF CALLS TO F',I13/
     +,' INTERVAL STRUCTURE..',5X,(25I4)//)
      IF(IPRINT.EQ.2) GOTO 25
      DO 19 I=1,NDIM
      WRITE(6,21)I
   21 FORMAT('0'/'0........ AXIS NUMBER',I3)
      K=MB(I)
      L=MA(I)+K
      K=K+1
      WRITE(6,22)(R(LA+J),J=K,L)
   22 FORMAT('0INTERVAL CHOICE'/(10E13.2))
      WRITE(6,23)(R(LC+J),J=K,L)
   23 FORMAT('0RELATIVE CONTRIBUTION TO INTEGRAL'/(10E13.2))
      WRITE(6,24)(R(LD+J),J=K,L)
   24 FORMAT('0RELATIVE CONTRIBUTION TO ERROR'/(10E13.2))
   19 CONTINUE
C
C********** CHECK IF ACCURACY REACHED OR END OF ITERATIONS
C
   25 ACC1=ERROR/ABS(VALUE)
      IF(ACC1.GT.ACC) GOTO 26
   28 IF(IPRINT.NE.0) WRITE(6,27) 'WAS',ITC,VALUE,ERROR
      RETURN
  26  IF(ITC.EQ.ITER) THEN
        IF(IPRINT.NE.0) WRITE(6,27)'NOT',ITC,VALUE,ERROR
        RETURN
      ENDIF
C
C********** RECOMPUTE INTERVAL SIZES
C
      L=0
      V=1.0
      DO 29 I=1,NDIM
      K=L+1
      M=MA(I)
      L=L+M
      X=0.0
      Y=0.0
      Z=0.0
      DO 30 J=K,L
      A=R(LA+J)
      C=R(LC+J)
      D=R(LD+J)
      GOTO (301,302,303,304),ICONV
  301 CONTINUE
      P=(1.0-A+ZERO)**ALFA
      Q=(-LOG(D+ZERO)+ZERO)**BETA
      GOTO 399
  302 CONTINUE
      P=A**ALFA
      Q=(D+ZERO)**(-BETA)
      GOTO 399
  303 CONTINUE
      P=((-LOG(D+ZERO)+ZERO)/(1.0-D+ZERO))**ALFA
      Q=((-LOG(A+ZERO)+ZERO)/(1.0-A+ZERO))**(-BETA)
      GOTO 399
  304 CONTINUE
      P=(1.0-LOG(D+ZERO))**ALFA
      Q=(1.0-LOG(A+ZERO))**(-BETA)
      GOTO 399
  399 CONTINUE
      B=A*P*Q
      R(LB+J)=B
      X=X+B
      Y=Y+D/A
   30 Z=Z+C**2/A
      B=ANSHT1 *Y*SV+(Z-1.0)*SI**2
      Y=B**GAMMA*M**DELTA
      V=V*Y
      XA(I)=Y
      X=1.0/X
      MC(I)=0
      DO 31 J=K,L
   31 R(LB+J)=R(LB+J)*X
   29 CONTINUE
C
C********** RECOMPUTE INTERVAL NUMBERS
C
      L=0
   34 Q=(ANSUB/(ANMIN**L*V))**(1.0/(NDIM-L))
      V=1.0
      K=0
      DO 32 I=1,NDIM
      M=MC(I)
      IF(M.EQ.NMIN) GOTO 32
      A=XA(I)*Q
      M=INT(A+0.5)
      IF(M.LE.NMIN) GOTO 33
      XA(I)=A
      V=V*A
      MC(I)=M
      GOTO 32
   33 MC(I)=NMIN
      K=K+1
   32 CONTINUE
      L=L+K
      IF(K.NE.0) GOTO 34
C
C********** COMBINE SIZES AND NUMBERS INTO NEW INTERVALS
C
      NID114=0
      DO 35 I=1,NDIM
   35 NID114=NID114+MC(I)
      IF(5*NID114.GT.LR) GOTO 107
      L=0
      L1=0
      DO 36 I=1,NDIM
      K=L+1
      K1=L1+1
      M=MC(I)
      M1=MA(I)
      L=L+M
      L1=L1+M1
      A=REAL(M1)/REAL(M)
      A=A*ONE
      C=0.0
      DO 38 J=K,L
      B=C
      C=C+A
      I1=INT(B)
      I2=INT(C)
      X=0.0
      DO 39 I3=I1,I2
   39 X=X+R(LB+K1+I3)
   38 R(LE+J)=X-(I2+1-C)*R(LB+K1+I2)-(B-I1)*R(LB+K1+I1)
   36 CONTINUE
      DO 40 L=1,NID114
   40 R(LA+L)=R(LE+L)
      DO 41 I=1,NDIM
   41 MA(I)=MC(I)
      GOTO 1
C
C********** NOT STORAGE ENOUGH
C
  107 X1=ANDIM*ANSUB**RNDIM
      X2=ANMIN*(ANDIM-1.0)+ANSUB/ANMIN**(ANDIM-1.0)
      X1=5.0*X1
      X2=5.0*X2
      X3=SQRT(X1*X2)
      I1=INT(X1)
      I2=INT(X2)
      I3=INT(X3)
      WRITE(6,108)LR,I1,I2,I3
  108 FORMAT('0'/' STORAGE LENGTH =',I5,'  IS TOO SMALL'/
     +,' MINIMUM NECESSARY -',I7/' MAXIMUM POSSIBLE - ',I7/
     +,' PROBABLE VALUE - ',I9)
      STOP 1
C
C********** TOO SMALL NUMBER OF SUBVOLUMES
C
  207 L=NMIN**NDIM
      WRITE(6,206)NSUB,L
  206 FORMAT('0 NSUB TOO SMALL...',I7/
     +,' MINIMUM NECESSARY...',I7)
      STOP 2
C
C ********** ZERO VARIANCE ABORT
C
  400 WRITE(6,401)
  401 FORMAT('0FUNCTION HAS ZERO VARIANCE')
      STOP 3
   27 FORMAT('0'/'0********'/
     +,' THE DESIRED ACCURACY ',A,' OBTAINED AFTER',I4,' ITERATIONS'//
     + ' FINAL VALUE...',E13.5/
     + ' FINAL ERROR...',E13.5/'0........')
      END
CDECK  ID>, RIWIBD. 
      SUBROUTINE RIWIBD
C   BLOCK DATA SUBSTITUTE
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/STORE/XA(11),XB(11),XC(11),XD(11),MA(11),MB(11),MC(11)
      COMMON/STORE1/R(10000),LR
      COMMON/OPTION/IPRINT,ICONV,IRESET
      COMMON/RANDOM/NSHOTS
      COMMON/INTERN/FACTOR,ALFA,BETA,GAMMA,DELTA,LEVEL,NMIN
      DATA INIT/0/
      IF(INIT.EQ.1) RETURN
      INIT=1
      MA(1)=0
      LR=10000
      IPRINT=1
      ICONV=1
      IRESET=0
      NSHOTS=2
      FACTOR=1.65
      LEVEL=90
      ALFA=0.3
      BETA=0.3
      GAMMA=0.3
      DELTA=.7
      NMIN=2
      RETURN
      END
CDECK  ID>, CHEBQU. 
      DOUBLE PRECISION FUNCTION CHEBQU(A,B,EPSIN,EPSOUT,JOP,FUNC)
C
C     BASIC VERSION AUGUST 1971.
C     PURPOSE = TO OBTAIN THE VALUE OF A REAL AND DEFINITE INTEGRAL AP-
C               PROXIMATING THE INTEGRAND F(X) BY
C               F(X)=.5*C(1)+C(2)*T(X,1)+............+C(M)*T(X,M-1)
C               WHERE T(X,K) IS THE CHEBYSHEV POLYNOMIAL OF ORDER K.
C               MODIFIED CLENSHAW/CURTIS METHOD REWRITTEN AS AN ORDINARY
C               QUADRATURE FORMULA.
C     THE BASIC THEORY FOR THE MODIFIED CLENSHAW-CURTIS ALGORITHM IS GI-
C     VEN IN T.HAAVIE , ON A MODIFICATION OF THE C355081W 3URT90 QUA-
C     DRATURE FORMULA , BIT 9(1969),338-350.
C     THE FORMULAS RELATED TO REWRITING THE ALGORITHM AS AN ORDINARY
C     QUADRATURE FORMULA IS GIVEN IN , T.HAAVIE , SOME METHODS FOR AUTO-
C     MATIC INTEGRATION AND THEIR IMPLEMENTATION ON THE CERN 65/6600
C     COMPUTERS , (YELLOW REPORT) CERN 71-   , GENEVA 1971.
C     PARAMETERS
C     A       = LOWER BOUNDARY
C     B       = UPPER BOUNDARY
C     EPSIN   = ACCURACY REQUIRED FOR THE APPROXINATION
C     EPSOUT  = IMPROVED ERROR ESTIMATE FOR THE APPROXIMATION
C     JOP     = OPTION PARAMETER , JOP=0 , NO PRINTING OF INTERMEDIATE
C                                          CALCULATIONS
C                                  JOP=1 , PRINT INTERMEDIATE CALCULA-
C                                          TIONS
C     FUNC    = FUNCTION ROUTINE FOR THE FUNCTION FUNC(X).TO BE DE-
C               CLARED EXTERNAL IN THE CALLING ROUTINE
C     PARAMETERS IN COMMON BLOCK / CHEINT /
C     TEND    = UPPER BOUND FOR VALUE OF INTEGRAL,I.E. TEND=TN*=TN+DN.
C     UMID    = LOWER BOUND FOR VALUE OF INTEGRAL,I.E. UMID=UN*=UN+DN.
C     DELN    = DN , DEFINITION FOLLOWS FROM DESCRIPTION OF TEND,UMID.
C     N       = THE NUMBER OF INTEGRAND VALUES USED IN THE CALCULATION
      EXTERNAL FUNC
      DOUBLE PRECISION A,B,EPSIN,EPSOUT,FUNC
C     VARIABLES DEPENDING ON STEPSIZE
      DOUBLE PRECISION ALF,BET,RN,HNSTEP,TEND,UMID,WMEAN,DELN,TNEW,TSUM
     1               , ACOFO , ACOFN , BCOFO , VALUE
C     OTHER VARIABLES USED
      DOUBLE PRECISION CONST1,CONST2,XPLUS,XMIN,BOUNDS , A0 , A1 , A2 ,
     1                 A3    , A4
      COMMON /CHEINT/ TEND , UMID , DELN , N
C     PARAMETERS IN THE COMMON BLOCK / DPCHEB /
C     (THESE PARAMETERS ARE PRESET IN COMMON BY MEANS OF A BLOCK DATA
C     SUBPROGRAM AND CONTAIN THE WEIGHTS AND ABSCISSAE FOR QUADRATURE
C     FORMULAS OF INCREASING ORDER.)
C     NUPPER  = N CORRESPONDS TO 2**(N+1) SUB-INTERVALS FOR THE UNFOLDED
C               INTEGRAL.THE MAX NO OF FUNCTION EVALUATIONS THUS BEING
C               1+2**(N+1).THE HIGHEST END-POINT APPROXIMATION IS THUS
C               USING 2**(N+1) INTERVALS WHILE THE HIGHEST MID-POINT AP-
C               PROXIMATION IS USING 2**N INTERVALS.
C     BETQJ   = AN ARRAY CONTAINING THE WEIGHTS OF THE MID-POINT FORMU-
C               LAS 1 THROUGH NUPPER.
C               DIMENSION BETQJ(2**N-1)
C     KSIQJ   = AN ARRAY CONTAINING THE ABSCISSAE OF THE MID-POINT FOR-
C               MULAS OF ORDER 1 THROUGH NUPPER.
C               DIMENSION KSIQJ(2**N-1)
C     ALFQJ   = AN ARRAY CONTAINING THE WEIGHTS OF THE END-POINT FORMU-
C               LAS OF ORDER 2 THROUGH NUPPER+1.
C               DIMENSION ALFQJ(2**(N+1)+N-2)
      DOUBLE PRECISION BETQJ , KSIQJ , ALFQJ , FVAL
C     IN THIS VERSION OF CHEBQU NUPPER=9 , THE DIMENSIONS OF THE ARRAYS
C     IN THE COMMON BLOCK / DPCHEB / THUS BEING
      COMMON /DPCHEB/ BETQJ(511),KSIQJ(511),ALFQJ(1031),NUPPER
C     SOME INTERNAL PARAMETERS.
C     FVAL    = AN INTERNAL ARRAY USED FOR STORING THE INTEGRAND VALU-
C               ES.
C               DIMENSION FVAL(2**N+1)
C     RNDERR  = 1.D-28 , THE RELATIVE MACHINE ACCURACY IN DOUBLE PRECI-
C               SION (CDC-6000 SERIE).
C     IN THIS VERSION OF CHEBQU NUPPER=9 , THE DIMENSION OF FVAL THUS
C     BEING.
      DIMENSION FVAL(513)
      DOUBLE PRECISION ZERO,HALF,ONE,TWO,TWTHIR
      DATA ZERO , HALF , ONE , TWO / 0.D0 , .5D0 , 1.D0 , 2.D0 /
      DATA TWTHIR/.666666666666666666666666666667D0/
C     SET INITIAL VALUES OF CONSTANTS
      DATA IBD/0/
      IF(IBD.EQ.0) CALL D115BD(IBD)
C     THIS IS A CALL TO A SUBROUTINE WHICH ONLY GIVES VALUES TO THE
C     ARRAYS IN THE COMMON BLOCK DPCHEB BY DATA STATEMENTS
C     INTEGRATION INTERVAL PARAMETERS
C*UL 1000 ALF=HALF*(B-A)
      ALF=HALF*(B-A)
      BET=HALF*(B+A)
      JNCR=2**(NUPPER-1)
      INCR=2*JNCR
C
C     PARAMETERS FOR INTEGRATION STEPSIZE AND LOOPS
      RN    =TWO
      N     =2
      NHALF =1
      HNSTEP=ONE
C
C     INITIAL CALCULATION FOR THE END-POINT APPROXIMATION
      CONST1=HALF*(FUNC(A)+FUNC(B))
      CONST2=FUNC(BET)
      ACOFO=HALF*(CONST1+CONST2)
      ACOFN=HALF*(CONST1-CONST2)
      TEND =TWTHIR*(CONST1+TWO*CONST2)
      FVAL(1)=CONST2+CONST2
      FVAL(INCR+1)=CONST1+CONST1
C
C     START ACTUAL CALCULATION
C
C---  Transform this DO-loop into a GOTO to avoid illegal jumps into it
C
C     DO 1150 I=1,NUPPER
      I=0
1021  I=I+1
      IF(I.GT.NUPPER) GOTO 1150
C
C     COMPUTE FUNCTION VALUES,CORRECTION TO MID-POINT APPROXIMATION AND
C     MID-POINT APPROXIMATION.
      BCOFO =ZERO
      UMID  =ZERO
      DO 1030 J=1,NHALF
      INDEX= NHALF+J-1
      XPLUS= ALF*KSIQJ(INDEX)+BET
      XMIN =-ALF*KSIQJ(INDEX)+BET
      VALUE= FUNC(XPLUS)+FUNC(XMIN)
      BCOFO= BCOFO+VALUE
      UMID = UMID+BETQJ(INDEX)*VALUE
      INDEX= (2*J-1)*JNCR+1
      FVAL(INDEX)=VALUE
 1030 CONTINUE
C
      UMID = UMID-TWO*ACOFN/(RN**2-ONE)
      BCOFO= HALF*HNSTEP*BCOFO
C
C     COMPUTE NEW END-POINT APPROXIMATION WHEN THE INTERVAL OF INTEGRA-
C     TION IS DIVIDED IN 2N EQUAL SUB INTERVALS
      WMEAN =HALF*(TEND+UMID)
      BOUNDS=HALF*(TEND-UMID)
      IPOINT=I+N-2
      TSUM  =ALFQJ(IPOINT)*FVAL(1)
      DO 1110 J=1,N
      INDEX=1+J*JNCR
      TSUM  =TSUM+ALFQJ(IPOINT+J)*FVAL(INDEX)
 1110 CONTINUE
      DELN  =TSUM-WMEAN
      ACOFN =HALF*(ACOFO-BCOFO)
      ACOFO =ACOFO-ACOFN
C     ******************************************************************
C     *                                                                *
C     PRINT INTERMEDIATE RESULTS IF WANTED
      IF (JOP.EQ.0) GO TO 1120
      GO TO 2000
C     *                                                                *
C     ******************************************************************
 1120 TNEW =TSUM
      EPSOUT=ABS(BOUNDS/TNEW)
      IF (EPSOUT.GT.EPSIN) GO TO 1130
C
C     REQUIRED ACCURACY OBTAINED OR THE MAXIMUM NUMBER OF FUNTION VAL-
C     UES USED WITHOUT OBTAINING THE REQUIRED ACCURACY.
 1124 N=2*N+1
C*UL 1125 TEND=ALF*(TEND+DELN)
      TEND=ALF*(TEND+DELN)
      UMID=ALF*(UMID+DELN)
      DELN=ALF*DELN
C*UL 1126 CHEBQU=ALF*TNEW
C*UL 1128 RETURN
      CHEBQU=ALF*TNEW
      RETURN
C
C     CALCULATION FINISHED.
C
 1130 IF (I.EQ.NUPPER) GO TO 1124
C
C     IF I=NUPPER THEN THE REQUIRED ACCURACY IS NOT OBTAINED.
C     PREPARE PARAMETERS FOR NEXT INTERVAL HALVING.
      TEND=TNEW
      NHALF =N
      N     =2*N
      RN    =TWO*RN
      INCR=JNCR
      JNCR=JNCR/2
      HNSTEP=HALF*HNSTEP
      GOTO 1021
 1150 CONTINUE
C     ******************************************************************
C     *                                                                *
C     PRINT INTERMEDIATE RESULTS
 2000 A0     = ALF*TEND
      A1     = ALF*WMEAN
      A2     = ALF*UMID
      CONST1 = ALF*BOUNDS
      CONST2 = ALF*DELN
      A3     = A0+CONST2
      A4     = A2+CONST2
C
      IF (I.GT.1) GO TO 2010
      WRITE(6,10)
 2010 WRITE(6,20)  N , A0
      WRITE(6,30)  A3
      WRITE(6,30)  A1 , CONST2 , CONST1
      WRITE(6,30)  A4
      WRITE(6,30)  A2
C
      GO TO 1120
C
 10   FORMAT(6X,'N',17X,'TEND  ',
     1            /,24X,'TEND* ',
     2            /,20X,'(TEND+UMID)/2',28X,'DELTAN',34X,'(TEND-UMID)/2'
     3  ,         /,24X,'UMID* ',
     4            /,24X,'UMID  ')
 20   FORMAT(/,4X,I3,2X,D36.29)
 30   FORMAT(9X,D36.29,3X,D36.29,3X,D36.29)
C     *                                                                *
C     ******************************************************************
      END
